summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/bell.test57
-rw-r--r--tests/bgerror.test45
-rw-r--r--tests/bind.test7992
-rw-r--r--tests/bitmap.test82
-rw-r--r--tests/border.test158
-rw-r--r--tests/busy.test477
-rw-r--r--tests/button.test4401
-rw-r--r--tests/canvImg.test809
-rw-r--r--tests/canvMoveto.test56
-rw-r--r--tests/canvPs.test45
-rw-r--r--tests/canvRect.test599
-rw-r--r--tests/canvText.test914
-rw-r--r--tests/canvWind.test43
-rw-r--r--tests/canvas.test762
-rw-r--r--tests/choosedir.test82
-rw-r--r--tests/clipboard.test361
-rw-r--r--tests/clrpick.test191
-rw-r--r--tests/cmds.test50
-rw-r--r--tests/config.test2135
-rw-r--r--tests/constraints.tcl39
-rw-r--r--tests/cursor.test900
-rw-r--r--tests/dialog.test75
-rw-r--r--tests/embed.test96
-rw-r--r--tests/entry.test3701
-rw-r--r--tests/event.test211
-rw-r--r--tests/focus.test556
-rw-r--r--tests/focusTcl.test483
-rw-r--r--tests/font.test2806
-rw-r--r--tests/fontchooser.test201
-rw-r--r--tests/frame.test1483
-rw-r--r--tests/geometry.test168
-rw-r--r--tests/get.test132
-rw-r--r--tests/grab.test218
-rw-r--r--tests/grid.test1961
-rw-r--r--tests/id.test91
-rw-r--r--tests/image.test639
-rw-r--r--tests/imgBmap.test490
-rw-r--r--tests/imgPNG.test1116
-rw-r--r--tests/imgPPM.test212
-rw-r--r--tests/imgPhoto.test1553
-rw-r--r--tests/listbox.test2862
-rw-r--r--tests/main.test136
-rw-r--r--tests/menu.test4664
-rw-r--r--tests/menuDraw.test778
-rw-r--r--tests/menubut.test817
-rw-r--r--tests/message.test534
-rw-r--r--tests/msgbox.test466
-rw-r--r--tests/obj.test22
-rw-r--r--tests/oldpack.test577
-rw-r--r--tests/option.test503
-rw-r--r--tests/pack.test1797
-rw-r--r--tests/packgrid.test250
-rw-r--r--tests/panedwindow.test5619
-rw-r--r--tests/place.test435
-rw-r--r--tests/raise.test201
-rw-r--r--tests/safe.test200
-rw-r--r--tests/scale.test1494
-rw-r--r--tests/scrollbar.test8
-rw-r--r--tests/select.test681
-rw-r--r--tests/send.test4
-rw-r--r--tests/spinbox.test4031
-rw-r--r--tests/text.test8327
-rw-r--r--tests/textBTree.test1087
-rw-r--r--tests/textImage.test692
-rw-r--r--tests/textIndex.test2
-rw-r--r--tests/textMark.test236
-rw-r--r--tests/textTag.test1664
-rw-r--r--tests/textWind.test1188
-rw-r--r--tests/tk.test204
-rw-r--r--tests/ttk/treeview.test4
-rw-r--r--tests/ttk/ttk.test14
-rw-r--r--tests/unixButton.test199
-rw-r--r--tests/unixEmbed.test596
-rw-r--r--tests/unixMenu.test1179
-rw-r--r--tests/unixSelect.test420
-rw-r--r--tests/util.test66
-rw-r--r--tests/visual.test562
-rw-r--r--tests/visual_bb.test54
-rw-r--r--tests/winButton.test172
-rw-r--r--tests/winClipboard.test116
-rw-r--r--tests/winDialog.test251
-rw-r--r--tests/winFont.test454
-rw-r--r--tests/winMenu.test1257
-rw-r--r--tests/winMsgbox.test45
-rw-r--r--tests/winSend.test2
-rw-r--r--tests/winWm.test321
-rw-r--r--tests/window.test201
-rw-r--r--tests/winfo.test599
-rw-r--r--tests/wm.test14
-rw-r--r--tests/xmfbox.test107
90 files changed, 57672 insertions, 24830 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 85372f8..c777d66 100644
--- a/tests/bind.test
+++ b/tests/bind.test
@@ -7,2741 +7,6051 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
tk useinputmethods 0
-catch {destroy .b}
-toplevel .b -width 100 -height 50
-wm geom .b +0+0
+toplevel .t -width 100 -height 50
+wm geom .t +0+0
update idletasks
-proc setup {} {
- catch {destroy .b.f}
- frame .b.f -class Test -width 150 -height 100
- pack .b.f
- focus -force .b.f
- foreach p [event info] {event delete $p}
- update
+foreach p [event info] {event delete $p}
+foreach event [bind Test] {
+ bind Test $event {}
}
-setup
-
-foreach i [bind Test] {
- bind Test $i {}
+foreach event [bind all] {
+ bind all $event {}
}
-foreach i [bind all] {
- bind all $i {}
+
+
+proc unsetBindings {} {
+ bind all <Enter> {}
+ bind Test <Enter> {}
+ bind Toplevel <Enter> {}
+ bind xyz <Enter> {}
+ bind {a b} <Enter> {}
+ bind .t <Enter> {}
}
-test bind-1.1 {bind command} {
- list [catch {bind} msg] $msg
-} {1 {wrong # args: should be "bind window ?pattern? ?command?"}}
-test bind-1.2 {bind command} {
- list [catch {bind a b c d} msg] $msg
-} {1 {wrong # args: should be "bind window ?pattern? ?command?"}}
-test bind-1.3 {bind command} {
- list [catch {bind .gorp} msg] $msg
-} {1 {bad window path name ".gorp"}}
-test bind-1.4 {bind command} {
- list [catch {bind foo} msg] $msg
-} {0 {}}
-test bind-1.5 {bind command} {
- list [catch {bind .b <gorp-> {}} msg] $msg
-} {0 {}}
-test bind-1.6 {bind command} {
- catch {destroy .b.f}
- frame .b.f
- bind .b.f <Enter> {test script}
- set result [bind .b.f <Enter>]
- bind .b.f <Enter> {}
- list $result [bind .b.f <Enter>]
-} {{test script} {}}
-test bind-1.7 {bind command} {
- catch {destroy .b.f}
- frame .b.f
- bind .b.f <Enter> {test script}
- bind .b.f <Enter> {+more text}
- bind .b.f <Enter>
-} {test script
+
+test bind-1.1 {bind command} -body {
+ bind
+} -returnCodes error -result {wrong # args: should be "bind window ?pattern? ?command?"}
+test bind-1.2 {bind command} -body {
+ bind a b c d
+} -returnCodes error -result {wrong # args: should be "bind window ?pattern? ?command?"}
+test bind-1.3 {bind command} -body {
+ bind .gorp
+} -returnCodes error -result {bad window path name ".gorp"}
+test bind-1.4 {bind command} -body {
+ bind foo
+} -returnCodes ok -result {}
+test bind-1.5 {bind command} -body {
+ bind .t <gorp-> {}
+} -returnCodes ok -result {}
+test bind-1.6 {bind command} -body {
+ frame .t.f
+ bind .t.f <Enter> {test script}
+ set result [bind .t.f <Enter>]
+ bind .t.f <Enter> {}
+ list $result [bind .t.f <Enter>]
+} -cleanup {
+ destroy .t.f
+} -result {{test script} {}}
+test bind-1.7 {bind command} -body {
+ frame .t.f
+ bind .t.f <Enter> {test script}
+ bind .t.f <Enter> {+more text}
+ bind .t.f <Enter>
+} -cleanup {
+ destroy .t.f
+} -result {test script
more text}
-test bind-1.8 {bind command} {
- list [catch {bind .b <gorp-> {test script}} msg] $msg [bind .b]
-} {1 {bad event type or keysym "gorp"} {}}
-test bind-1.9 {bind command} {
- list [catch {bind .b <gorp->} msg] $msg
-} {0 {}}
-test bind-1.10 {bind command} {
- catch {destroy .b.f}
- frame .b.f
- bind .b.f <Enter> {script 1}
- bind .b.f <Leave> {script 2}
- bind .b.f a {script for a}
- bind .b.f b {script for b}
- lsort [bind .b.f]
-} {<Enter> <Leave> a b}
-
-test bind-2.1 {bindtags command} {
- list [catch {bindtags} msg] $msg
-} {1 {wrong # args: should be "bindtags window ?taglist?"}}
-test bind-2.2 {bindtags command} {
- list [catch {bindtags a b c} msg] $msg
-} {1 {wrong # args: should be "bindtags window ?taglist?"}}
-test bind-2.3 {bindtags command} {
- list [catch {bindtags .foo} msg] $msg
-} {1 {bad window path name ".foo"}}
-test bind-2.4 {bindtags command} {
- bindtags .b
-} {.b Toplevel all}
-test bind-2.5 {bindtags command} {
- catch {destroy .b.f}
- frame .b.f
- bindtags .b.f
-} {.b.f Frame .b all}
-test bind-2.6 {bindtags command} {
- catch {destroy .b.f}
- frame .b.f
- bindtags .b.f {{x y z} b c d}
- bindtags .b.f
-} {{x y z} b c d}
-test bind-2.7 {bindtags command} {
- catch {destroy .b.f}
- frame .b.f
- bindtags .b.f {x y z}
- bindtags .b.f {}
- bindtags .b.f
-} {.b.f Frame .b all}
-test bind-2.8 {bindtags command} {
- catch {destroy .b.f}
- frame .b.f
- bindtags .b.f {x y z}
- bindtags .b.f {a b c d}
- bindtags .b.f
-} {a b c d}
-test bind-2.9 {bindtags command} {
- catch {destroy .b.f}
- frame .b.f
- bindtags .b.f {a b c}
- list [catch {bindtags .b.f "\{"} msg] $msg [bindtags .b.f]
-} {1 {unmatched open brace in list} {.b.f Frame .b all}}
-test bind-2.10 {bindtags command} {
- catch {destroy .b.f}
- frame .b.f
- bindtags .b.f {a b c}
- list [catch {bindtags .b.f "a .gorp b"} msg] $msg [bindtags .b.f]
-} {0 {} {a .gorp b}}
-test bind-3.1 {TkFreeBindingTags procedure} {
- catch {destroy .b.f}
- frame .b.f
- bindtags .b.f "a b c d"
- destroy .b.f
-} {}
-test bind-3.2 {TkFreeBindingTags procedure} {
- catch {destroy .b.f}
- frame .b.f
- catch {bindtags .b.f "a .gorp b .b.f"}
- destroy .b.f
-} {}
-
-bind all <Enter> {lappend x "%W enter all"}
-bind Test <Enter> {lappend x "%W enter frame"}
-bind Toplevel <Enter> {lappend x "%W enter toplevel"}
-bind xyz <Enter> {lappend x "%W enter xyz"}
-bind {a b} <Enter> {lappend x "%W enter {a b}"}
-bind .b <Enter> {lappend x "%W enter .b"}
-test bind-4.1 {TkBindEventProc procedure} {
- catch {destroy .b.f}
- frame .b.f -class Test -width 150 -height 100
- pack .b.f
- update
- bind .b.f <Enter> {lappend x "%W enter .b.f"}
- set x {}
- event gen .b.f <Enter>
- set x
-} {{.b.f enter .b.f} {.b.f enter frame} {.b.f enter .b} {.b.f enter all}}
-test bind-4.2 {TkBindEventProc procedure} {
- catch {destroy .b.f}
- frame .b.f -class Test -width 150 -height 100
- pack .b.f
- update
- bind .b.f <Enter> {lappend x "%W enter .b.f"}
- bindtags .b.f {.b.f {a b} xyz}
- set x {}
- event gen .b.f <Enter>
- set x
-} {{.b.f enter .b.f} {.b.f enter {a b}} {.b.f enter xyz}}
-test bind-4.3 {TkBindEventProc procedure} {
- set x {}
- event gen .b <Enter>
- set x
-} {{.b enter .b} {.b enter toplevel} {.b enter all}}
-test bind-4.4 {TkBindEventProc procedure} {
- catch {destroy .b.f}
- frame .b.f -class Test -width 150 -height 100
- pack .b.f
- update
- bindtags .b.f {.b.f .b.f2 .b.f3}
- frame .b.f3 -width 50 -height 50
- pack .b.f3
- bind .b.f <Enter> {lappend x "%W enter .b.f"}
- bind .b.f3 <Enter> {lappend x "%W enter .b.f3"}
- set x {}
- event gen .b.f <Enter>
- destroy .b.f3
- set x
-} {{.b.f enter .b.f} {.b.f enter .b.f3}}
-test bind-4.5 {TkBindEventProc procedure} {
+test bind-1.8 {bind command} -body {
+ bind .t <gorp-> {test script}
+} -returnCodes error -result {bad event type or keysym "gorp"}
+test bind-1.9 {bind command} -body {
+ catch {bind .t <gorp-> {test script}}
+ bind .t
+} -result {}
+test bind-1.10 {bind command} -body {
+ bind .t <gorp->
+} -returnCodes ok -result {}
+test bind-1.11 {bind command} -body {
+ frame .t.f
+ bind .t.f <Enter> {script 1}
+ bind .t.f <Leave> {script 2}
+ bind .t.f a {script for a}
+ bind .t.f b {script for b}
+ lsort [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {<Enter> <Leave> a b}
+
+test bind-2.1 {bindtags command} -body {
+ bindtags
+} -returnCodes error -result {wrong # args: should be "bindtags window ?taglist?"}
+test bind-2.2 {bindtags command} -body {
+ bindtags a b c
+} -returnCodes error -result {wrong # args: should be "bindtags window ?taglist?"}
+test bind-2.3 {bindtags command} -body {
+ bindtags .foo
+} -returnCodes error -result {bad window path name ".foo"}
+test bind-2.4 {bindtags command} -body {
+ bindtags .t
+} -result {.t Toplevel all}
+test bind-2.5 {bindtags command} -body {
+ frame .t.f
+ bindtags .t.f
+} -cleanup {
+ destroy .t.f
+} -result {.t.f Frame .t all}
+test bind-2.6 {bindtags command} -body {
+ frame .t.f
+ bindtags .t.f {{x y z} b c d}
+ bindtags .t.f
+} -cleanup {
+ destroy .t.f
+} -result {{x y z} b c d}
+test bind-2.7 {bindtags command} -body {
+ frame .t.f
+ bindtags .t.f {x y z}
+ bindtags .t.f {}
+ bindtags .t.f
+} -cleanup {
+ destroy .t.f
+} -result {.t.f Frame .t all}
+test bind-2.8 {bindtags command} -body {
+ frame .t.f
+ bindtags .t.f {x y z}
+ bindtags .t.f {a b c d}
+ bindtags .t.f
+} -cleanup {
+ destroy .t.f
+} -result {a b c d}
+test bind-2.9 {bindtags command} -body {
+ frame .t.f
+ bindtags .t.f {a b c}
+ bindtags .t.f "\{"
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {unmatched open brace in list}
+test bind-2.10 {bindtags command} -body {
+ frame .t.f
+ bindtags .t.f {a b c}
+ catch {bindtags .t.f "\{"}
+ bindtags .t.f
+} -cleanup {
+ destroy .t.f
+} -result {.t.f Frame .t all}
+test bind-2.11 {bindtags command} -body {
+ frame .t.f
+ bindtags .t.f {a b c}
+ bindtags .t.f "a .gorp b"
+} -cleanup {
+ destroy .t.f
+} -returnCodes ok
+test bind-2.12 {bindtags command} -body {
+ frame .t.f
+ bindtags .t.f {a b c}
+ catch {bindtags .t.f "a .gorp b"}
+ bindtags .t.f
+} -cleanup {
+ destroy .t.f
+} -result {a .gorp b}
+
+
+test bind-3.1 {TkFreeBindingTags procedure} -body {
+ frame .t.f
+ bindtags .t.f "a b c d"
+ destroy .t.f
+} -cleanup {
+ destroy .t.f
+} -result {}
+test bind-3.2 {TkFreeBindingTags procedure} -body {
+ frame .t.f
+ catch {bindtags .t.f "a .gorp b .t.f"}
+ destroy .t.f
+} -cleanup {
+ destroy .t.f
+} -result {}
+
+
+test bind-4.1 {TkBindEventProc procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ update
+ set x {}
+} -body {
+ bind all <Enter> {lappend x "%W enter all"}
+ bind Test <Enter> {lappend x "%W enter frame"}
+ bind Toplevel <Enter> {lappend x "%W enter toplevel"}
+ bind xyz <Enter> {lappend x "%W enter xyz"}
+ bind {a b} <Enter> {lappend x "%W enter {a b}"}
+ bind .t <Enter> {lappend x "%W enter .t"}
+ bind .t.f <Enter> {lappend x "%W enter .t.f"}
+
+ event generate .t.f <Enter>
+ return $x
+} -cleanup {
+ destroy .t.f
+ unsetBindings
+} -result {{.t.f enter .t.f} {.t.f enter frame} {.t.f enter .t} {.t.f enter all}}
+test bind-4.2 {TkBindEventProc procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ update
+ set x {}
+} -body {
+ bind all <Enter> {lappend x "%W enter all"}
+ bind Test <Enter> {lappend x "%W enter frame"}
+ bind Toplevel <Enter> {lappend x "%W enter toplevel"}
+ bind xyz <Enter> {lappend x "%W enter xyz"}
+ bind {a b} <Enter> {lappend x "%W enter {a b}"}
+ bind .t <Enter> {lappend x "%W enter .t"}
+ bind .t.f <Enter> {lappend x "%W enter .t.f"}
+
+ bindtags .t.f {.t.f {a b} xyz}
+ event generate .t.f <Enter>
+ return $x
+} -cleanup {
+ destroy .t.f
+ unsetBindings
+} -result {{.t.f enter .t.f} {.t.f enter {a b}} {.t.f enter xyz}}
+test bind-4.3 {TkBindEventProc procedure} -body {
+ set x {}
+ bind all <Enter> {lappend x "%W enter all"}
+ bind Test <Enter> {lappend x "%W enter frame"}
+ bind Toplevel <Enter> {lappend x "%W enter toplevel"}
+ bind xyz <Enter> {lappend x "%W enter xyz"}
+ bind {a b} <Enter> {lappend x "%W enter {a b}"}
+ bind .t <Enter> {lappend x "%W enter .t"}
+
+ event generate .t <Enter>
+ return $x
+} -cleanup {
+ unsetBindings
+} -result {{.t enter .t} {.t enter toplevel} {.t enter all}}
+test bind-4.4 {TkBindEventProc procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ frame .t.f3 -width 50 -height 50
+ pack .t.f3
+ update
+ set x {}
+} -body {
+ bind all <Enter> {lappend x "%W enter all"}
+ bind Test <Enter> {lappend x "%W enter frame"}
+ bind Toplevel <Enter> {lappend x "%W enter toplevel"}
+ bind xyz <Enter> {lappend x "%W enter xyz"}
+ bind {a b} <Enter> {lappend x "%W enter {a b}"}
+ bind .t <Enter> {lappend x "%W enter .t"}
+
+ bindtags .t.f {.t.f .t.f2 .t.f3}
+ bind .t.f <Enter> {lappend x "%W enter .t.f"}
+ bind .t.f3 <Enter> {lappend x "%W enter .t.f3"}
+ event generate .t.f <Enter>
+ return $x
+} -cleanup {
+ destroy .t.f .t.f3
+ unsetBindings
+} -result {{.t.f enter .t.f} {.t.f enter .t.f3}}
+test bind-4.5 {TkBindEventProc procedure} -setup {
# This tests memory allocation for objPtr; it won't serve any useful
# purpose unless run with some sort of allocation checker turned on.
- catch {destroy .b.f}
- frame .b.f -class Test -width 150 -height 100
- pack .b.f
- update
- bindtags .b.f {a b c d e f g h i j k l m n o p q r s t u v w x y z}
- event gen .b.f <Enter>
-} {}
-bind all <Enter> {}
-bind Test <Enter> {}
-bind Toplevel <Enter> {}
-bind xyz <Enter> {}
-bind {a b} <Enter> {}
-bind .b <Enter> {}
-
-test bind-5.1 {Tk_CreateBindingTable procedure} {
- catch {destroy .b.c}
- canvas .b.c
- .b.c bind foo
-} {}
-
-test bind-6.1 {Tk_DeleteBindTable procedure} {
- catch {destroy .b.c}
- canvas .b.c
- .b.c bind foo <1> {string 1}
- .b.c create rectangle 0 0 100 100
- .b.c bind 1 <2> {string 2}
- destroy .b.c
-} {}
-test bind-6.2 {Tk_DeleteBindTable procedure: pending bindings deleted later} testcbind {
- catch {interp delete foo}
- interp create foo
- foo eval {
- load {} Tk
- tk useinputmethods 0
- load {} Tktest
- wm geometry . +0+0
- frame .t -width 50 -height 50
- bindtags .t {a b c d}
- pack .t
- update
- set x {}
- testcbind a <1> "lappend x a1; destroy ." "lappend x bye.a1"
- bind b <1> "lappend x b1"
- testcbind c <1> "lappend x c1" "lappend x bye.c1"
- testcbind c <2> "lappend x all2" "lappend x bye.all2"
- event gen .t <1>
- }
- set x [foo eval set x]
- interp delete foo
- set x
-} {a1 bye.all2 bye.a1 b1 bye.c1}
-
-test bind-7.1 {Tk_CreateBinding procedure: bad binding} {
- catch {destroy .b.c}
- canvas .b.c
- list [catch {.b.c bind foo <} msg] $msg
-} {1 {no event type or button # or keysym}}
-test bind-7.2 {Tk_CreateBinding procedure: replace existing C binding} testcbind {
- catch {destroy .b.f}
- frame .b.f
- testcbind .b.f <1> "xyz" "lappend x bye.1"
- set x {}
- bind .b.f <1> "abc"
- destroy .b.f
- set x
-} {bye.1}
-test bind-7.3 {Tk_CreateBinding procedure: append} {
- catch {destroy .b.c}
- canvas .b.c
- .b.c bind foo <1> "button 1"
- .b.c bind foo <1> "+more button 1"
- .b.c bind foo <1>
-} {button 1
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ update
+} -body {
+ bind all <Enter> {lappend x "%W enter all"}
+ bind Test <Enter> {lappend x "%W enter frame"}
+ bind Toplevel <Enter> {lappend x "%W enter toplevel"}
+ bind xyz <Enter> {lappend x "%W enter xyz"}
+ bind {a b} <Enter> {lappend x "%W enter {a b}"}
+ bind .t <Enter> {lappend x "%W enter .t"}
+ bindtags .t.f {a b c d e f g h i j k l m n o p q r s t u v w x y z}
+
+ event generate .t.f <Enter>
+} -cleanup {
+ destroy .t.f
+ unsetBindings
+} -result {}
+
+
+test bind-5.1 {Tk_CreateBindingTable procedure} -body {
+ canvas .t.c
+ .t.c bind foo
+} -cleanup {
+ destroy .t.c
+} -result {}
+
+
+test bind-6.1 {Tk_DeleteBindTable procedure} -body {
+ canvas .t.c
+ .t.c bind foo <1> {string 1}
+ .t.c create rectangle 0 0 100 100
+ .t.c bind 1 <2> {string 2}
+ destroy .t.c
+} -cleanup {
+ destroy .t.c
+} -result {}
+test bind-7.1 {Tk_CreateBinding procedure: bad binding} -body {
+ canvas .t.c
+ .t.c bind foo <
+} -cleanup {
+ destroy .t.c
+} -returnCodes error -result {no event type or button # or keysym}
+test bind-7.3 {Tk_CreateBinding procedure: append} -body {
+ canvas .t.c
+ .t.c bind foo <1> "button 1"
+ .t.c bind foo <1> "+more button 1"
+ .t.c bind foo <1>
+} -cleanup {
+ destroy .t.c
+} -result {button 1
more button 1}
-test bind-7.4 {Tk_CreateBinding procedure: append to non-existing} {
- catch {destroy .b.c}
- canvas .b.c
- .b.c bind foo <1> "+button 1"
- .b.c bind foo <1>
-} {button 1}
-
-test bind-8.1 {TkCreateBindingProcedure: error} testcbind {
- list [catch {testcbind . <xyz> "xyz"} msg] $msg
-} {1 {bad event type or keysym "xyz"}}
-test bind-8.2 {TkCreateBindingProcedure: new binding} testcbind {
- catch {destroy .b.f}
- frame .b.f
- testcbind .b.f <1> "lappend x 1" "lappend x bye.1"
- set x {}
- event gen .b.f <1>
- destroy .b.f
- set x
-} {bye.1}
-test bind-8.3 {TkCreateBindingProcedure: replace existing} testcbind {
- catch {destroy .b.f}
- frame .b.f
- pack .b.f
- set x {}
- testcbind .b.f <1> "lappend x old1" "lappend x bye.old1"
- testcbind .b.f <1> "lappend x new1" "lappend x bye.new1"
- set x
-} {bye.old1}
-test bind-8.4 {TkCreateBindingProcedure: replace existing while pending} testcbind {
- catch {destroy .b.f}
- frame .b.f
- pack .b.f
- update
- testcbind .b.f <1> "lappend x .b.f; testcbind Frame <1> {lappend x Frame}"
- testcbind Frame <1> "lappend x never"
- set x {}
- event gen .b.f <1>
- bind .b.f <1> {}
- set x
-} {.b.f Frame}
-
-test bind-9.1 {Tk_DeleteBinding procedure} {
- catch {destroy .b.f}
- frame .b.f -class Test -width 150 -height 100
- list [catch {bind .b.f <} msg] $msg
-} {0 {}}
-test bind-9.2 {Tk_DeleteBinding procedure} {
- catch {destroy .b.f}
- frame .b.f -class Test -width 150 -height 100
+test bind-7.4 {Tk_CreateBinding procedure: append to non-existing} -body {
+ canvas .t.c
+ .t.c bind foo <1> "+button 1"
+ .t.c bind foo <1>
+} -cleanup {
+ destroy .t.c
+} -result {button 1}
+
+test bind-8.1 {Tk_CreateBinding: error} -body {
+ bind . <xyz> "xyz"
+} -returnCodes error -result {bad event type or keysym "xyz"}
+
+test bind-9.1 {Tk_DeleteBinding procedure} -body {
+ frame .t.f -class Test -width 150 -height 100
+ bind .t.f <
+} -cleanup {
+ destroy .t.f
+} -returnCodes ok
+test bind-9.2 {Tk_DeleteBinding procedure} -setup {
+ set result {}
+} -body {
+ frame .t.f -class Test -width 150 -height 100
foreach i {a b c d} {
- bind .b.f $i "binding for $i"
+ bind .t.f $i "binding for $i"
}
- set result {}
foreach i {b d a c} {
- bind .b.f $i {}
- lappend result [lsort [bind .b.f]]
+ bind .t.f $i {}
+ lappend result [lsort [bind .t.f]]
}
- set result
-} {{a c d} {a c} c {}}
-test bind-9.3 {Tk_DeleteBinding procedure} {
- catch {destroy .b.f}
- frame .b.f -class Test -width 150 -height 100
+ return $result
+} -cleanup {
+ destroy .t.f
+} -result {{a c d} {a c} c {}}
+test bind-9.3 {Tk_DeleteBinding procedure} -setup {
+ set result {}
+} -body {
+ frame .t.f -class Test -width 150 -height 100
foreach i {<1> <Meta-1> <Control-1> <Double-Alt-1>} {
- bind .b.f $i "binding for $i"
+ bind .t.f $i "binding for $i"
}
- set result {}
foreach i {<Control-1> <Double-Alt-1> <1> <Meta-1>} {
- bind .b.f $i {}
- lappend result [lsort [bind .b.f]]
+ bind .t.f $i {}
+ lappend result [lsort [bind .t.f]]
}
- set result
-} {{<Button-1> <Double-Alt-Button-1> <Meta-Button-1>} {<Button-1> <Meta-Button-1>} <Meta-Button-1> {}}
-test bind-9.4 {Tk_DeleteBinding procedure: pending bindings delete later} testcbind {
- catch {destroy .b.f}
- frame .b.f
- pack .b.f
- update
- bindtags .b.f {a b c}
- testcbind a <1> {lappend x a1; bind c <1> {}; bind c <2> {}} {lappend x bye.a1}
- bind b <1> {lappend x b1}
- testcbind c <1> {lappend x c1} {lappend x bye.c1}
- testcbind c <2> {lappend x c2} {lappend x bye.c2}
- set x {}
- event gen .b.f <1>
- bind a <1> {}
- bind b <1> {}
- set x
-} {a1 bye.c2 b1 bye.c1 bye.a1}
-
-test bind-10.1 {Tk_GetBinding procedure} {
- catch {destroy .b.c}
- canvas .b.c
- list [catch {.b.c bind foo <} msg] $msg
-} {1 {no event type or button # or keysym}}
-test bind-10.2 {Tk_GetBinding procedure} {
- catch {destroy .b.c}
- canvas .b.c
- .b.c bind foo a Test
- .b.c bind foo a
-} {Test}
-test bind-10.3 {Tk_GetBinding procedure: C binding} testcbind {
- catch {destroy .b.f}
- frame .b.f
- testcbind .b.f <1> "foo"
- list [bind .b.f] [bind .b.f <1>]
-} {<Button-1> {}}
-
-test bind-11.1 {Tk_GetAllBindings procedure} {
- catch {destroy .b.f}
- frame .b.f -class Test -width 150 -height 100
+ return $result
+} -cleanup {
+ destroy .t.f
+} -result {{<Button-1> <Double-Alt-Button-1> <Meta-Button-1>} {<Button-1> <Meta-Button-1>} <Meta-Button-1> {}}
+
+test bind-10.1 {Tk_GetBinding procedure} -body {
+ canvas .t.c
+ .t.c bind foo <
+} -cleanup {
+ destroy .t.c
+} -returnCodes error -result {no event type or button # or keysym}
+test bind-10.2 {Tk_GetBinding procedure} -body {
+ canvas .t.c
+ .t.c bind foo a Test
+ .t.c bind foo a
+} -cleanup {
+ destroy .t.c
+} -result {Test}
+
+test bind-11.1 {Tk_GetAllBindings procedure} -body {
+ frame .t.f
foreach i "! a \\\{ ~ <Delete> <space> <<Paste>> <Tab> <Linefeed> <less> <Meta-a> <Acircumflex>" {
- bind .b.f $i Test
+ bind .t.f $i Test
}
- lsort [bind .b.f]
-} {! <<Paste>> <Key-Acircumflex> <Key-Delete> <Key-Linefeed> <Key-Tab> <Key-less> <Key-space> <Meta-Key-a> a \{ ~}
-test bind-11.2 {Tk_GetAllBindings procedure} {
- catch {destroy .b.f}
- frame .b.f -class Test -width 150 -height 100
+ lsort [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {! <<Paste>> <Key-Acircumflex> <Key-Delete> <Key-Linefeed> <Key-Tab> <Key-less> <Key-space> <Meta-Key-a> a \{ ~}
+test bind-11.2 {Tk_GetAllBindings procedure} -body {
+ frame .t.f
foreach i "<Double-1> <Triple-1> <Meta-Control-a> <Double-Alt-Enter> <1>" {
- bind .b.f $i Test
+ bind .t.f $i Test
}
- lsort [bind .b.f]
-} {<Button-1> <Control-Meta-Key-a> <Double-Alt-Enter> <Double-Button-1> <Triple-Button-1>}
-test bind-11.3 {Tk_GetAllBindings procedure} {
- catch {destroy .b.f}
- frame .b.f -class Test -width 150 -height 100
+ lsort [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {<Button-1> <Control-Meta-Key-a> <Double-Alt-Enter> <Double-Button-1> <Triple-Button-1>}
+test bind-11.3 {Tk_GetAllBindings procedure} -body {
+ frame .t.f
foreach i "<Double-Triple-1> abcd a<Leave>b" {
- bind .b.f $i Test
+ bind .t.f $i Test
}
- lsort [bind .b.f]
-} {<Triple-Button-1> a<Leave>b abcd}
-
-
-test bind-12.1 {Tk_DeleteAllBindings procedure} {
- catch {destroy .b.f}
- frame .b.f -class Test -width 150 -height 100
- destroy .b.f
-} {}
-test bind-12.2 {Tk_DeleteAllBindings procedure} {
- catch {destroy .b.f}
- frame .b.f -class Test -width 150 -height 100
+ lsort [bind .t.f]
+} -cleanup {
+ destroy .t.f
+} -result {<Triple-Button-1> a<Leave>b abcd}
+
+
+test bind-12.1 {Tk_DeleteAllBindings procedure} -body {
+ frame .t.f -class Test -width 150 -height 100
+ destroy .t.f
+} -result {}
+test bind-12.2 {Tk_DeleteAllBindings procedure} -body {
+ frame .t.f -class Test -width 150 -height 100
foreach i "a b c <Meta-1> <Alt-a> <Control-a>" {
- bind .b.f $i x
+ bind .t.f $i x
}
- destroy .b.f
-} {}
-test bind-12.3 {Tk_DeleteAllBindings procedure: pending bindings deleted later} testcbind {
- catch {destroy .b.f}
- frame .b.f
- pack .b.f
+ destroy .t.f
+} -result {}
+
+test bind-13.1 {Tk_BindEvent procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
update
- testcbind .b.f <1> {lappend x before; event gen .b.f <2>; lappend x after} {lappend x bye.f1}
- testcbind .b.f <2> {destroy .b.f} {lappend x bye.f2}
- bind .b.f <Destroy> {lappend x fDestroy}
- testcbind .b.f <3> {foo} {lappend x bye.f3}
set x {}
- event gen .b.f <1>
- set x
-} {before fDestroy bye.f3 bye.f2 after bye.f1}
-
-bind Test <KeyPress> {lappend x "%W %K Test press any"}
-bind all <KeyPress> {lappend x "%W %K all press any"}
-bind Test a {lappend x "%W %K Test press a"}
-bind all x {lappend x "%W %K all press x"}
+} -body {
+ bind Test <KeyPress> {lappend x "%W %K Test KeyPress"}
+ bind all <KeyPress> {lappend x "%W %K all KeyPress"}
+ bind Test : {lappend x "%W %K Test :"}
+ bind all _ {lappend x "%W %K all _"}
+ bind .t.f : {lappend x "%W %K .t.f :"}
+
+ event generate .t.f <Key-colon>
+ event generate .t.f <Key-plus>
+ event generate .t.f <Key-underscore>
+ return $x
+} -cleanup {
+ destroy .t.f
+ bind all <KeyPress> {}
+ bind Test <KeyPress> {}
+ bind all _ {}
+ bind Test : {}
+} -result {{.t.f colon .t.f :} {.t.f colon Test :} {.t.f colon all KeyPress} {.t.f plus Test KeyPress} {.t.f plus all KeyPress} {.t.f underscore Test KeyPress} {.t.f underscore all _}}
-test bind-13.1 {Tk_BindEvent procedure} {
- setup
- bind .b.f a {lappend x "%W %K .b.f press a"}
+test bind-13.2 {Tk_BindEvent procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- event gen .b.f <Key-a>
- event gen .b.f <Key-b>
- event gen .b.f <Key-x>
- set x
-} {{.b.f a .b.f press a} {.b.f a Test press a} {.b.f a all press any} {.b.f b Test press any} {.b.f b all press any} {.b.f x Test press any} {.b.f x all press x}}
-
-bind Test <KeyPress> {lappend x "%W %K Test press any"; break}
-bind all <KeyPress> {continue; lappend x "%W %K all press any"}
+} -body {
+ bind Test <KeyPress> {lappend x "%W %K Test press any"; break}
+ bind all <KeyPress> {continue; lappend x "%W %K all press any"}
+ bind .t.f : {lappend x "%W %K .t.f pressed colon"}
+
+ event generate .t.f <Key-colon>
+ return $x
+} -cleanup {
+ destroy .t.f
+ bind all <KeyPress> {}
+ bind Test <KeyPress> {}
+} -result {{.t.f colon .t.f pressed colon} {.t.f colon Test press any}}
-test bind-13.2 {Tk_BindEvent procedure} {
- setup
- bind .b.f b {lappend x "%W %K .b.f press a"}
- set x {}
- event gen .b.f <Key-b>
- set x
-} {{.b.f b .b.f press a} {.b.f b Test press any}}
-if {[info procs bgerror] == "bgerror"} {
- rename bgerror {}
-}
-proc bgerror args {}
-bind Test <KeyPress> {lappend x "%W %K Test press any"; error Test}
-test bind-13.3 {Tk_BindEvent procedure} {
- setup
- bind .b.f b {lappend x "%W %K .b.f press a"}
+test bind-13.3 {Tk_BindEvent procedure} -setup {
+ proc bgerror args {}
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- event gen .b.f <Key-b>
+} -body {
+ bind Test <KeyPress> {lappend x "%W %K Test press any"; error Test}
+ bind .t.f : {lappend x "%W %K .t.f pressed colon"}
+ event generate .t.f <Key-colon>
update
list $x $errorInfo
-} {{{.b.f b .b.f press a} {.b.f b Test press any}} {Test
+} -cleanup {
+ destroy .t.f
+ bind Test <KeyPress> {}
+ rename bgerror {}
+} -result {{{.t.f colon .t.f pressed colon} {.t.f colon Test press any}} {Test
while executing
"error Test"
(command bound to event)}}
-rename bgerror {}
-test bind-13.4 {Tk_BindEvent procedure} {
+test bind-13.4 {Tk_BindEvent procedure} -setup {
proc foo {} {
- set x 44
- event gen .b.f <Key-a>
+ set x 44
+ event generate .t.f <Key-colon>
}
- setup
- bind .b.f a {lappend x "%W %K .b.f press a"}
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
+} -body {
+ bind Test : {lappend x "%W %K Test"}
+ bind .t.f : {lappend x "%W %K .t.f"}
foo
- set x
-} {{.b.f a .b.f press a} {.b.f a Test press a}}
-test bind-13.5 {Tk_BindEvent procedure} {
+ return $x
+} -cleanup {
+ destroy .t.f
+ bind Test : {}
+} -result {{.t.f colon .t.f} {.t.f colon Test}}
+
+test bind-13.5 {Tk_BindEvent procedure} -body {
bind all <Destroy> {lappend x "%W destroyed"}
set x {}
- list [catch {frame .b.g -gorp foo} msg] $msg $x
-} {1 {unknown option "-gorp"} {{.b.g destroyed}}}
-foreach i [bind all] {
- bind all $i {}
-}
-foreach i [bind Test] {
- bind Test $i {}
-}
-test bind-13.6 {Tk_BindEvent procedure} {
- setup
- bind .b.f z {lappend x "%W z (.b.f binding)"}
- bind Test z {lappend x "%W z (.b.f binding)"}
- bind all z {bind .b.f z {}; lappend x "%W z (.b.f binding)"}
- set x {}
- event gen .b.f <Key-z>
- bind Test z {}
- bind all z {}
- set x
-} {{.b.f z (.b.f binding)} {.b.f z (.b.f binding)} {.b.f z (.b.f binding)}}
-test bind-13.7 {Tk_BindEvent procedure} {
- setup
- bind .b.f z {lappend x "%W z (.b.f binding)"}
- bind Test z {lappend x "%W z (.b.f binding)"}
- bind all z {destroy .b.f; lappend x "%W z (.b.f binding)"}
- set x {}
- event gen .b.f <Key-z>
- bind Test z {}
- bind all z {}
- set x
-} {{.b.f z (.b.f binding)} {.b.f z (.b.f binding)} {.b.f z (.b.f binding)}}
-test bind-13.8 {Tk_BindEvent procedure} {
- setup
- bind .b.f <1> {lappend x "%W z (.b.f <1> binding)"}
- bind .b.f <ButtonPress> {lappend x "%W z (.b.f <ButtonPress> binding)"}
- set x {}
- event gen .b.f <Button-1>
- event gen .b.f <Button-2>
- set x
-} {{.b.f z (.b.f <1> binding)} {.b.f z (.b.f <ButtonPress> binding)}}
-test bind-13.9 {Tk_BindEvent procedure: ignore NotifyInferior} {
- setup
- bind .b.f <Enter> "lappend x Enter%#"
- bind .b.f <Leave> "lappend x Leave%#"
- set x {}
- event gen .b.f <Enter> -serial 100 -detail NotifyAncestor
- event gen .b.f <Enter> -serial 101 -detail NotifyInferior
- event gen .b.f <Leave> -serial 102 -detail NotifyAncestor
- event gen .b.f <Leave> -serial 103 -detail NotifyInferior
- set x
-} {Enter100 Leave102}
-test bind-13.10 {Tk_BindEvent procedure: collapse Motions} {
- setup
- bind .b.f <Motion> "lappend x Motion%#(%x,%y)"
- set x {}
- event gen .b.f <Motion> -serial 100 -x 100 -y 200 -when tail
- update
- event gen .b.f <Motion> -serial 101 -x 200 -y 300 -when tail
- event gen .b.f <Motion> -serial 102 -x 300 -y 400 -when tail
- update
- set x
-} {Motion100(100,200) Motion102(300,400)}
-test bind-13.11 {Tk_BindEvent procedure: collapse repeating modifiers} {
- setup
- bind .b.f <Key> "lappend x %K%#"
- bind .b.f <KeyRelease> "lappend x %K%#"
- event gen .b.f <Key-Shift_L> -serial 100 -when tail
- event gen .b.f <KeyRelease-Shift_L> -serial 101 -when tail
- event gen .b.f <Key-Shift_L> -serial 102 -when tail
- event gen .b.f <KeyRelease-Shift_L> -serial 103 -when tail
- update
-} {}
-test bind-13.12 {Tk_BindEvent procedure: valid key detail} {
- setup
- bind .b.f <Key> "lappend x Key%K"
- bind .b.f <KeyRelease> "lappend x Release%K"
- set x {}
- event gen .b.f <Key> -keysym a
- event gen .b.f <KeyRelease> -keysym a
- set x
-} {Keya Releasea}
-test bind-13.13 {Tk_BindEvent procedure: invalid key detail} {
- setup
- bind .b.f <Key> "lappend x Key%K"
- bind .b.f <KeyRelease> "lappend x Release%K"
- set x {}
- event gen .b.f <Key> -keycode 0
- event gen .b.f <KeyRelease> -keycode 0
- set x
-} {Key?? Release??}
-test bind-13.14 {Tk_BindEvent procedure: button detail} {
- setup
- bind .b.f <Button> "lappend x Button%b"
- bind .b.f <ButtonRelease> "lappend x Release%b"
- set x {}
- event gen .b.f <Button> -button 1
- event gen .b.f <ButtonRelease> -button 3
- set x
-} {Button1 Release3}
-test bind-13.15 {Tk_BindEvent procedure: virtual detail} {
- setup
- bind .b.f <<Paste>> "lappend x Paste"
- set x {}
- event gen .b.f <<Paste>>
- set x
-} {Paste}
-test bind-13.16 {Tk_BindEvent procedure: virtual event in event stream} {
- setup
- bind .b.f <<Paste>> "lappend x Paste"
- set x {}
- event gen .b.f <<Paste>>
- set x
-} {Paste}
-test bind-13.17 {Tk_BindEvent procedure: match detail physical} {
- setup
- bind .b.f <Button-2> {set x Button-2}
- event add <<Paste>> <Button-2>
- bind .b.f <<Paste>> {set x Paste}
+ frame .t.g -gorp foo
+} -cleanup {
+ bind all <Destroy> {}
+} -returnCodes error -result {unknown option "-gorp"}
+test bind-13.6 {Tk_BindEvent procedure} -body {
+ bind all <Destroy> {lappend x "%W destroyed"}
+ set x {}
+ catch {frame .t.g -gorp foo}
+ return $x
+} -cleanup {
+ bind all <Destroy> {}
+} -result {{.t.g destroyed}}
+
+test bind-13.7 {Tk_BindEvent procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f : {lappend x "%W (.t.f binding)"}
+ bind Test : {lappend x "%W (Test binding)"}
+ bind all : {bind .t.f : {}; lappend x "%W (all binding)"}
+ event generate .t.f <Key-colon>
+ return $x
+} -cleanup {
+ bind Test : {}
+ bind all : {}
+ destroy .t.f
+} -result {{.t.f (.t.f binding)} {.t.f (Test binding)} {.t.f (all binding)}}
+test bind-13.8 {Tk_BindEvent procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f : {lappend x "%W (.t.f binding)"}
+ bind Test : {lappend x "%W (Test binding)"}
+ bind all : {destroy .t.f; lappend x "%W (all binding)"}
+ event generate .t.f <Key-colon>
+ return $x
+} -cleanup {
+ bind Test : {}
+ bind all : {}
+ destroy .t.f
+} -result {{.t.f (.t.f binding)} {.t.f (Test binding)} {.t.f (all binding)}}
+
+test bind-13.9 {Tk_BindEvent procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <1> {lappend x "%W z (.t.f <1> binding)"}
+ bind .t.f <ButtonPress> {lappend x "%W z (.t.f <ButtonPress> binding)"}
+ event generate .t.f <Button-1>
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {{.t.f z (.t.f <1> binding)} {.t.f z (.t.f <ButtonPress> binding)}}
+test bind-13.10 {Tk_BindEvent procedure: ignore NotifyInferior} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Enter> "lappend x Enter%#"
+ bind .t.f <Leave> "lappend x Leave%#"
+ event generate .t.f <Enter> -serial 100 -detail NotifyAncestor
+ event generate .t.f <Enter> -serial 101 -detail NotifyInferior
+ event generate .t.f <Leave> -serial 102 -detail NotifyAncestor
+ event generate .t.f <Leave> -serial 103 -detail NotifyInferior
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {Enter100 Leave102}
+test bind-13.11 {Tk_BindEvent procedure: collapse Motions} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Motion> "lappend x Motion%#(%x,%y)"
+ event generate .t.f <Motion> -serial 100 -x 100 -y 200 -when tail
+ update
+ event generate .t.f <Motion> -serial 101 -x 200 -y 300 -when tail
+ event generate .t.f <Motion> -serial 102 -x 300 -y 400 -when tail
+ update
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {Motion100(100,200) Motion102(300,400)}
+test bind-13.12 {Tk_BindEvent procedure: collapse repeating modifiers} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Key> "lappend x %K%#"
+ bind .t.f <KeyRelease> "lappend x %K%#"
+ event generate .t.f <Key-Shift_L> -serial 100 -when tail
+ event generate .t.f <KeyRelease-Shift_L> -serial 101 -when tail
+ event generate .t.f <Key-Shift_L> -serial 102 -when tail
+ event generate .t.f <KeyRelease-Shift_L> -serial 103 -when tail
+ update
+} -cleanup {
+ destroy .t.f
+} -result {}
+test bind-13.13 {Tk_BindEvent procedure: valid key detail} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- event gen .b.f <Button-2>
+} -body {
+ bind .t.f <Key> "lappend x Key%K"
+ bind .t.f <KeyRelease> "lappend x Release%K"
+ event generate .t.f <Key> -keysym colon
+ event generate .t.f <KeyRelease> -keysym colon
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {Keycolon Releasecolon}
+test bind-13.14 {Tk_BindEvent procedure: invalid key detail} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> "lappend x Key%K"
+ bind .t.f <KeyRelease> "lappend x Release%K"
+ event generate .t.f <Key> -keycode 0
+ event generate .t.f <KeyRelease> -keycode 0
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {Key?? Release??}
+test bind-13.15 {Tk_BindEvent procedure: button detail} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button> "lappend x Button%b"
+ bind .t.f <ButtonRelease> "lappend x Release%b"
+ event generate .t.f <Button> -button 1
+ event generate .t.f <ButtonRelease> -button 3
set x
-} {Button-2}
-test bind-13.18 {Tk_BindEvent procedure: no match detail physical} {
- setup
+} -cleanup {
+ destroy .t.f
+} -result {Button1 Release3}
+test bind-13.16 {Tk_BindEvent procedure: virtual detail} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <<Paste>> "lappend x Paste"
+ event generate .t.f <<Paste>>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {Paste}
+test bind-13.17 {Tk_BindEvent procedure: virtual event in event stream} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <<Paste>> "lappend x Paste"
+ event generate .t.f <<Paste>>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {Paste}
+test bind-13.18 {Tk_BindEvent procedure: match detail physical} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button-2> {set x Button-2}
event add <<Paste>> <Button-2>
- bind .b.f <<Paste>> {set x Paste}
+ bind .t.f <<Paste>> {set x Paste}
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+ event delete <<Paste>> <Button-2>
+} -result {Button-2}
+
+test bind-13.19 {Tk_BindEvent procedure: no match detail physical} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- event gen .b.f <Button-2>
- set x
-} {Paste}
-test bind-13.19 {Tk_BindEvent procedure: match detail virtual} {
- setup
+} -body {
event add <<Paste>> <Button-2>
- bind .b.f <<Paste>> "lappend x Paste"
+ bind .t.f <<Paste>> {set x Paste}
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+ event delete <<Paste>> <Button-2>
+} -result {Paste}
+test bind-13.20 {Tk_BindEvent procedure: match detail virtual} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- event gen .b.f <Button-2>
- set x
-} {Paste}
-test bind-13.20 {Tk_BindEvent procedure: no match detail virtual} {
- setup
+} -body {
event add <<Paste>> <Button-2>
- bind .b.f <<Paste>> "lappend x Paste"
+ bind .t.f <<Paste>> "lappend x Paste"
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+ event delete <<Paste>> <Button-2>
+} -result {Paste}
+test bind-13.21 {Tk_BindEvent procedure: no match detail virtual} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- event gen .b.f <Button>
- set x
-} {}
-test bind-13.21 {Tk_BindEvent procedure: match no-detail physical} {
- setup
- bind .b.f <Button> {set x Button}
+} -body {
+ event add <<Paste>> <Button-2>
+ bind .t.f <<Paste>> "lappend x Paste"
+ event generate .t.f <Button>
+ return $x
+} -cleanup {
+ destroy .t.f
+ event delete <<Paste>> <Button-2>
+} -result {}
+test bind-13.22 {Tk_BindEvent procedure: match no-detail physical} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button> {set x Button}
event add <<Paste>> <Button>
- bind .b.f <<Paste>> {set x Paste}
+ bind .t.f <<Paste>> {set x Paste}
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+ event delete <<Paste>> <Button>
+} -result {Button}
+test bind-13.23 {Tk_BindEvent procedure: no match no-detail physical} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- event gen .b.f <Button-2>
- set x
-} {Button}
-test bind-13.22 {Tk_BindEvent procedure: no match no-detail physical} {
- setup
+} -body {
event add <<Paste>> <Button>
- bind .b.f <<Paste>> {set x Paste}
+ bind .t.f <<Paste>> {set x Paste}
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+ event delete <<Paste>> <Button>
+} -result {Paste}
+test bind-13.24 {Tk_BindEvent procedure: match no-detail virtual} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- event gen .b.f <Button-2>
- set x
-} {Paste}
-test bind-13.23 {Tk_BindEvent procedure: match no-detail virtual} {
- setup
+} -body {
event add <<Paste>> <Button>
- bind .b.f <<Paste>> "lappend x Paste"
+ bind .t.f <<Paste>> "lappend x Paste"
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+ event delete <<Paste>> <Button>
+} -result {Paste}
+test bind-13.25 {Tk_BindEvent procedure: no match no-detail virtual} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- event gen .b.f <Button-2>
- set x
-} {Paste}
-test bind-13.24 {Tk_BindEvent procedure: no match no-detail virtual} {
- setup
+} -body {
event add <<Paste>> <Key>
- bind .b.f <<Paste>> "lappend x Paste"
+ bind .t.f <<Paste>> "lappend x Paste"
+ event generate .t.f <Button>
+ return $x
+} -cleanup {
+ destroy .t.f
+ event delete <<Paste>> <Key>
+} -result {}
+test bind-13.26 {Tk_BindEvent procedure: precedence} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- event gen .b.f <Button>
- set x
-} {}
-test bind-13.25 {Tk_BindEvent procedure: precedence} {
- setup
+} -body {
event add <<Paste>> <Button-2>
event add <<Copy>> <Button>
- bind .b.f <Button-2> "lappend x Button-2"
- bind .b.f <<Paste>> "lappend x Paste"
- bind .b.f <Button> "lappend x Button"
- bind .b.f <<Copy>> "lappend x Copy"
-
- set x {}
- event gen .b.f <Button-2>
- bind .b.f <Button-2> {}
- event gen .b.f <Button-2>
- bind .b.f <<Paste>> {}
- event gen .b.f <Button-2>
- bind .b.f <Button> {}
- event gen .b.f <Button-2>
- bind .b.f <<Copy>> {}
- event gen .b.f <Button-2>
- set x
-} {Button-2 Paste Button Copy}
-test bind-13.26 {Tk_BindEvent procedure: no detail virtual pattern list} {
- setup
- bind .b.f <Button-2> {set x Button-2}
- set x {}
- event gen .b.f <Button-2>
- set x
-} {Button-2}
-test bind-13.27 {Tk_BindEvent procedure: detail virtual pattern list} {
- setup
+ bind .t.f <Button-2> "lappend x Button-2"
+ bind .t.f <<Paste>> "lappend x Paste"
+ bind .t.f <Button> "lappend x Button"
+ bind .t.f <<Copy>> "lappend x Copy"
+
+ event generate .t.f <Button-2>
+ bind .t.f <Button-2> {}
+ event generate .t.f <Button-2>
+ bind .t.f <<Paste>> {}
+ event generate .t.f <Button-2>
+ bind .t.f <Button> {}
+ event generate .t.f <Button-2>
+ bind .t.f <<Copy>> {}
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+ event delete <<Paste>> <Button-2>
+ event delete <<Copy>> <Button>
+} -result {Button-2 Paste Button Copy}
+test bind-13.27 {Tk_BindEvent procedure: no detail virtual pattern list} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button-2> {set x Button-2}
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {Button-2}
+test bind-13.28 {Tk_BindEvent procedure: detail virtual pattern list} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
event add <<Paste>> <Button-2>
- bind .b.f <<Paste>> {set x Paste}
+ bind .t.f <<Paste>> {set x Paste}
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+ event delete <<Paste>> <Button-2>
+} -result {Paste}
+test bind-13.29 {Tk_BindEvent procedure: no no-detail virtual pattern list} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- event gen .b.f <Button-2>
- set x
-} {Paste}
-test bind-13.28 {Tk_BindEvent procedure: no no-detail virtual pattern list} {
- setup
- bind .b.f <Button> {set x Button}
+} -body {
+ bind .t.f <Button> {set x Button}
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {Button}
+test bind-13.30 {Tk_BindEvent procedure: no-detail virtual pattern list} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- event gen .b.f <Button-2>
- set x
-} {Button}
-test bind-13.29 {Tk_BindEvent procedure: no-detail virtual pattern list} {
- setup
+} -body {
event add <<Paste>> <Button>
- bind .b.f <<Paste>> {set x Paste}
- set x {}
- event gen .b.f <Button-2>
- set x
-} {Paste}
-test bind-13.30 {Tk_BindEvent procedure: no match} {
- setup
- event gen .b.f <Button-2>
-} {}
-test bind-13.31 {Tk_BindEvent procedure: match} {
- setup
- bind .b.f <Button-2> {set x Button-2}
- set x {}
- event gen .b.f <Button-2>
- set x
-} {Button-2}
-test bind-13.32 {Tk_BindEvent procedure: many C bindings cause realloc} testcbind {
- setup
- bindtags .b.f {a b c d e f g h i j k l m n o p}
- foreach p [bindtags .b.f] {
- testcbind $p <1> "lappend x $p"
- }
+ bind .t.f <<Paste>> {set x Paste}
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+ event delete <<Paste>> <Button>
+} -result {Paste}
+test bind-13.31 {Tk_BindEvent procedure: no match} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ event generate .t.f <Button-2>
+} -cleanup {
+ destroy .t.f
+} -result {}
+test bind-13.32 {Tk_BindEvent procedure: match} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Button-2> {set x Button-2}
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {Button-2}
+test bind-13.33 {Tk_BindEvent procedure: many C bindings cause realloc} -setup {
+ # this test might not be useful anymore [#3009998]
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- event gen .b.f <1>
- foreach p [bindtags .b.f] {
- bind $p <1> {}
+} -body {
+ bindtags .t.f {a b c d e f g h i j k l m n o p}
+ foreach p [bindtags .t.f] {
+ bind $p <1> "lappend x $p"
}
- set x
-} {a b c d e f g h i j k l m n o p}
-test bind-13.33 {Tk_BindEvent procedure: multiple tags} {
- setup
- bind .b.f <Button-2> {lappend x .b.f}
- bind Test <Button-2> {lappend x Button}
+ event generate .t.f <1>
+ return $x
+} -cleanup {
+ foreach p [bindtags .t.f] {bind $p <1> {}}
+ destroy .t.f
+} -result {a b c d e f g h i j k l m n o p}
+test bind-13.34 {Tk_BindEvent procedure: multiple tags} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- event gen .b.f <Button-2>
+} -body {
+ bind .t.f <Button-2> {lappend x .t.f}
+ bind Test <Button-2> {lappend x Button}
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
bind Test <Button-2> {}
- set x
-} {.b.f Button}
-test bind-13.34 {Tk_BindEvent procedure: execute C binding} testcbind {
- setup
- testcbind .b.f <1> {lappend x 1}
+} -result {.t.f Button}
+test bind-13.35 {Tk_BindEvent procedure: execute binding} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- event gen .b.f <1>
- set x
-} {1}
-test bind-13.35 {Tk_BindEvent procedure: pending list marked deleted} testcbind {
- setup
- testcbind Test <1> {lappend x Test} {lappend x Deleted}
- bind .b.f <1> {lappend x .b.f; destroy .b.f}
+} -body {
+ bind .t.f <1> {lappend x 1}
+ event generate .t.f <1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-13.38 {Tk_BindEvent procedure: binding gets to run} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- event gen .b.f <1>
- set y [list $x [bind Test]]
- bind Test <1> {}
- set y
-} {.b.f <Button-1>}
-test bind-13.36 {Tk_BindEvent procedure: C binding marked deleted} testcbind {
- setup
- testcbind Test <1> {lappend x Test} {lappend x Deleted}
- bind .b.f <1> {lappend x .b.f; bind Test <1> {}; lappend x after}
- set x {}
- event gen .b.f <1>
- set x
-} {.b.f after Deleted}
-test bind-13.37 {Tk_BindEvent procedure: C binding gets to run} testcbind {
- setup
- testcbind Test <1> {lappend x Test}
- bind .b.f <1> {lappend x .b.f}
- set x {}
- event gen .b.f <1>
+} -body {
+ bind Test <1> {lappend x Test}
+ bind .t.f <1> {lappend x .t.f}
+ event generate .t.f <1>
+ return $x
+} -cleanup {
+ destroy .t.f
bind Test <1> {}
- set x
-} {.b.f Test}
-test bind-13.38 {Tk_BindEvent procedure: C binding deleted, refcount == 0} testcbind {
- setup
- testcbind .b.f <1> {lappend x hi; bind .b.f <1> {}} {lappend x bye}
- set x {}
- event gen .b.f <1>
- set x
-} {hi bye}
-test bind-13.39 {Tk_BindEvent procedure: C binding deleted, refcount != 0} testcbind {
- setup
- testcbind .b.f <1> {
- lappend x before$n
- if {$n==0} {
- bind .b.f <1> {}
- } else {
- set n [expr $n-1]
- event gen .b.f <1>
- }
- lappend x after$n
- } {lappend x Deleted}
- set n 3
- set x {}
- event gen .b.f <1>
- set x
-} {before3 before2 before1 before0 after0 after0 after0 after0 Deleted}
-test bind-13.40 {Tk_BindEvent procedure: continue in script} {
- setup
- bind .b.f <Button-2> {lappend x b1; continue; lappend x b2}
- bind Test <Button-2> {lappend x B1; continue; lappend x B2}
+} -result {.t.f Test}
+test bind-13.41 {Tk_BindEvent procedure: continue in script} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- event gen .b.f <Button-2>
+} -body {
+ bind .t.f <Button-2> {lappend x b1; continue; lappend x b2}
+ bind Test <Button-2> {lappend x B1; continue; lappend x B2}
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
bind Test <Button-2> {}
- set x
-} {b1 B1}
-test bind-13.41 {Tk_BindEvent procedure: continue in script} testcbind {
- setup
- testcbind .b.f <Button-2> {lappend x b1; continue; lappend x b2}
- testcbind Test <Button-2> {lappend x B1; continue; lappend x B2}
+} -result {b1 B1}
+test bind-13.43 {Tk_BindEvent procedure: break in script} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- event gen .b.f <Button-2>
- bind Test <Button-2> {}
- set x
-} {b1 B1}
-test bind-13.42 {Tk_BindEvent procedure: break in script} {
- setup
- bind .b.f <Button-2> {lappend x b1; break; lappend x b2}
+} -body {
+ bind .t.f <Button-2> {lappend x b1; break; lappend x b2}
bind Test <Button-2> {lappend x B1; break; lappend x B2}
- set x {}
- event gen .b.f <Button-2>
+ event generate .t.f <Button-2>
+ return $x
+} -cleanup {
+ destroy .t.f
bind Test <Button-2> {}
- set x
-} {b1}
-test bind-13.43 {Tk_BindEvent procedure: break in script} testcbind {
- setup
- testcbind .b.f <Button-2> {lappend x b1; break; lappend x b2}
- testcbind Test <Button-2> {lappend x B1; break; lappend x B2}
+} -result {b1}
+test bind-13.45 {Tk_BindEvent procedure: error in script} -setup {
+ proc bgerror msg {
+ global x
+ lappend x $msg
+ }
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- event gen .b.f <Button-2>
- bind Test <Button-2> {}
- set x
-} {b1}
-
-proc bgerror msg {
- global x
- lappend x $msg
-}
-test bind-13.44 {Tk_BindEvent procedure: error in script} {
- setup
- bind .b.f <Button-2> {lappend x b1; blap}
+} -body {
+ bind .t.f <Button-2> {lappend x b1; blap}
bind Test <Button-2> {lappend x B1}
- set x {}
- event gen .b.f <Button-2>
+ event generate .t.f <Button-2>
update
+ return $x
+} -cleanup {
+ destroy .t.f
bind Test <Button-2> {}
- set x
-} {b1 {invalid command name "blap"}}
-test bind-13.45 {Tk_BindEvent procedure: error in script} testcbind {
- setup
- testcbind .b.f <Button-2> {lappend x b1; blap}
- testcbind Test <Button-2> {lappend x B1}
- set x {}
- event gen .b.f <Button-2>
+ proc bgerror args {}
+} -result {b1 {invalid command name "blap"}}
+
+test bind-15.1 {MatchPatterns procedure, ignoring type mismatches} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
update
- bind Test <Button-2> {}
- set x
-} {b1 {invalid command name "blap"}}
-
-test bind-14.1 {TkBindDeadWindow: no C bindings pending} testcbind {
- setup
- bind .b.f <1> x
- testcbind .b.f <2> y
- destroy .b.f
-} {}
-test bind-14.2 {TkBindDeadWindow: is called after <Destroy>} testcbind {
- setup
- testcbind .b.f <Destroy> "lappend x .b.f"
- testcbind Test <Destroy> "lappend x Test"
- set x {}
- destroy .b.f
- bind Test <Destroy> {}
- set x
-} {.b.f Test}
-test bind-14.3 {TkBindDeadWindow: pending C bindings} testcbind {
- setup
- bindtags .b.f {a b c d}
- testcbind a <1> "lappend x a1" "lappend x bye.a1"
- testcbind b <1> "destroy .b.f; lappend x b1" "lappend x bye.b1"
- testcbind c <1> "lappend x c1" "lappend x bye.c1"
- testcbind d <1> "lappend x d1" "lappend x bye.d1"
- bind a <2> "event gen .b.f <1>"
- testcbind b <2> "lappend x b2" "lappend x bye.b2"
- testcbind c <2> "lappend x c2" "lappend x bye.d2"
- bind d <2> "lappend x d2"
- testcbind a <3> "event gen .b.f <2>"
- set x {}
- event gen .b.f <3>
- set y $x
- foreach tag {a b c d} {
- foreach event {<1> <2> <3>} {
- bind $tag $event {}
- }
- }
- set y
-} {a1 b1 d2}
-
-test bind-15.1 {MatchPatterns procedure, ignoring type mismatches} {
- setup
- bind .b.f ab {set x 1}
+} -body {
+ bind .t.f 12 {set x 1}
set x 0
- event gen .b.f <Key-a>
- event gen .b.f <KeyRelease-a>
- event gen .b.f <Key-b>
- event gen .b.f <KeyRelease-b>
- set x
-} 1
-test bind-15.2 {MatchPatterns procedure, ignoring type mismatches} {
- setup
- bind .b.f ab {set x 1}
+ event generate .t.f <Key-1>
+ event generate .t.f <KeyRelease-1>
+ event generate .t.f <Key-2>
+ event generate .t.f <KeyRelease-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.2 {MatchPatterns procedure, ignoring type mismatches} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f 12 {set x 1}
set x 0
- event gen .b.f <Key-a>
- event gen .b.f <Enter>
- event gen .b.f <KeyRelease-a>
- event gen .b.f <Leave>
- event gen .b.f <Key-b>
- event gen .b.f <KeyRelease-b>
- set x
-} 1
-test bind-15.3 {MatchPatterns procedure, ignoring type mismatches} {
- setup
- bind .b.f ab {set x 1}
+ event generate .t.f <Key-1>
+ event generate .t.f <Enter>
+ event generate .t.f <KeyRelease-1>
+ event generate .t.f <Leave>
+ event generate .t.f <Key-2>
+ event generate .t.f <KeyRelease-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.3 {MatchPatterns procedure, ignoring type mismatches} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f 12 {set x 1}
set x 0
- event gen .b.f <Key-a>
- event gen .b.f <Button-1>
- event gen .b.f <Key-b>
- set x
-} 0
-test bind-15.4 {MatchPatterns procedure, ignoring type mismatches} {
- setup
- bind .b.f <Double-1> {set x 1}
+ event generate .t.f <Key-1>
+ event generate .t.f <Button-1>
+ event generate .t.f <Key-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {0}
+test bind-15.4 {MatchPatterns procedure, ignoring type mismatches} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-1> {set x 1}
set x 0
- event gen .b.f <Button-1>
- event gen .b.f <ButtonRelease-1>
- event gen .b.f <Button-1>
- event gen .b.f <ButtonRelease-1>
- set x
-} 1
-test bind-15.5 {MatchPatterns procedure, ignoring type mismatches} {
- setup
- bind .b.f <Double-ButtonRelease> {set x 1}
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.5 {MatchPatterns procedure, ignoring type mismatches} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-ButtonRelease> {set x 1}
set x 0
- event gen .b.f <Button-1>
- event gen .b.f <ButtonRelease-1>
- event gen .b.f <Button-2>
- event gen .b.f <ButtonRelease-2>
- set x
-} 1
-test bind-15.6 {MatchPatterns procedure, ignoring type mismatches} {
- setup
- bind .b.f <Double-1> {set x 1}
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.6 {MatchPatterns procedure, ignoring type mismatches} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-1> {set x 1}
set x 0
- event gen .b.f <Button-1>
- event gen .b.f <Key-a>
- event gen .b.f <ButtonRelease-1>
- event gen .b.f <Button-1>
- event gen .b.f <ButtonRelease-1>
- set x
-} 0
-test bind-15.7 {MatchPatterns procedure, ignoring type mismatches} {
- setup
- bind .b.f <Double-1> {set x 1}
+ event generate .t.f <Button-1>
+ event generate .t.f <Key-a>
+ event generate .t.f <ButtonRelease-1>
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {0}
+test bind-15.7 {MatchPatterns procedure, ignoring type mismatches} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-1> {set x 1}
set x 0
- event gen .b.f <Button-1>
- event gen .b.f <Key-Shift_L>
- event gen .b.f <ButtonRelease-1>
- event gen .b.f <Button-1>
- event gen .b.f <ButtonRelease-1>
- set x
-} 1
-test bind-15.8 {MatchPatterns procedure, ignoring type mismatches} {
- setup
- bind .b.f ab {set x 1}
+ event generate .t.f <Button-1>
+ event generate .t.f <Key-Shift_L>
+ event generate .t.f <ButtonRelease-1>
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.8 {MatchPatterns procedure, ignoring type mismatches} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f ab {set x 1}
set x 0
- event gen .b.f <Key-a>
- event gen .b.f <Key-c>
- event gen .b.f <Key-b>
- set x
-} 0
-test bind-15.9 {MatchPatterns procedure, modifier checks} {
- setup
- bind .b.f <M1-M2-Key> {set x 1}
+ event generate .t.f <Key-a>
+ event generate .t.f <Key-c>
+ event generate .t.f <Key-b>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {0}
+test bind-15.9 {MatchPatterns procedure, modifier checks} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <M1-M2-Key> {set x 1}
set x 0
- event gen .b.f <Key-a> -state 0x18
- set x
-} 1
-test bind-15.10 {MatchPatterns procedure, modifier checks} {
- setup
- bind .b.f <M1-M2-Key> {set x 1}
+ event generate .t.f <Key-a> -state 0x18
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.10 {MatchPatterns procedure, modifier checks} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <M1-M2-Key> {set x 1}
set x 0
- event gen .b.f <Key-a> -state 0xfc
- set x
-} 1
-test bind-15.11 {MatchPatterns procedure, modifier checks} {
- setup
- bind .b.f <M1-M2-Key> {set x 1}
+ event generate .t.f <Key-a> -state 0xfc
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.11 {MatchPatterns procedure, modifier checks} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <M1-M2-Key> {set x 1}
set x 0
- event gen .b.f <Key-a> -state 0x8
- set x
-} 0
-test bind-15.12 {MatchPatterns procedure, ignore modifier presses and releases} {nonPortable} {
+ event generate .t.f <Key-a> -state 0x8
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {0}
+test bind-15.12 {MatchPatterns procedure, ignore modifier presses and releases} -constraints {
+ nonPortable
+} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
# This test is non-portable because the Shift_L keysym may behave
# differently on some platforms.
- setup
- bind .b.f aB {set x 1}
+ bind .t.f aB {set x 1}
set x 0
- event gen .b.f <Key-a>
- event gen .b.f <Key-Shift_L>
- event gen .b.f <Key-b> -state 1
- set x
-} 1
-test bind-15.13 {MatchPatterns procedure, checking detail} {
- setup
- bind .b.f ab {set x 1}
+ event generate .t.f <Key-a>
+ event generate .t.f <Key-Shift_L>
+ event generate .t.f <Key-b> -state 1
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.13 {MatchPatterns procedure, checking detail} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f ab {set x 1}
set x 0
- event gen .b.f <Key-a>
- event gen .b.f <Key-c>
- set x
-} 0
-test bind-15.14 {MatchPatterns procedure, checking "nearby"} {
- setup
- bind .b.f <Double-1> {set x 1}
+ event generate .t.f <Key-a>
+ event generate .t.f <Key-c>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {0}
+test bind-15.14 {MatchPatterns procedure, checking "nearby"} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-1> {set x 1}
set x 0
- event gen .b.f <Button-2>
- event gen .b.f <ButtonRelease-2>
- event gen .b.f <Button-1> -x 30 -y 40
- event gen .b.f <Button-1> -x 31 -y 39
- event gen .b.f <ButtonRelease-1>
- set x
-} 1
-test bind-15.15 {MatchPatterns procedure, checking "nearby"} {
- setup
- bind .b.f <Double-1> {set x 1}
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Button-1> -x 30 -y 40
+ event generate .t.f <Button-1> -x 31 -y 39
+ event generate .t.f <ButtonRelease-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.15 {MatchPatterns procedure, checking "nearby"} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-1> {set x 1}
set x 0
- event gen .b.f <Button-2>
- event gen .b.f <ButtonRelease-2>
- event gen .b.f <Button-1> -x 30 -y 40
- event gen .b.f <Button-1> -x 29 -y 41
- event gen .b.f <ButtonRelease-1>
- set x
-} 1
-test bind-15.16 {MatchPatterns procedure, checking "nearby"} {
- setup
- bind .b.f <Double-1> {set x 1}
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Button-1> -x 30 -y 40
+ event generate .t.f <Button-1> -x 29 -y 41
+ event generate .t.f <ButtonRelease-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.16 {MatchPatterns procedure, checking "nearby"} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-1> {set x 1}
set x 0
- event gen .b.f <Button-2>
- event gen .b.f <ButtonRelease-2>
- event gen .b.f <Button-1> -x 30 -y 40
- event gen .b.f <Button-1> -x 40 -y 40
- event gen .b.f <ButtonRelease-2>
- set x
-} 0
-test bind-15.17 {MatchPatterns procedure, checking "nearby"} {
- setup
- bind .b.f <Double-1> {set x 1}
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Button-1> -x 30 -y 40
+ event generate .t.f <Button-1> -x 40 -y 40
+ event generate .t.f <ButtonRelease-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {0}
+test bind-15.17 {MatchPatterns procedure, checking "nearby"} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-1> {set x 1}
set x 0
- event gen .b.f <Button-2>
- event gen .b.f <ButtonRelease-2>
- event gen .b.f <Button-1> -x 30 -y 40
- event gen .b.f <Button-1> -x 20 -y 40
- event gen .b.f <ButtonRelease-1>
- set x
-} 0
-test bind-15.18 {MatchPatterns procedure, checking "nearby"} {
- setup
- bind .b.f <Double-1> {set x 1}
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Button-1> -x 30 -y 40
+ event generate .t.f <Button-1> -x 20 -y 40
+ event generate .t.f <ButtonRelease-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {0}
+test bind-15.18 {MatchPatterns procedure, checking "nearby"} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-1> {set x 1}
set x 0
- event gen .b.f <Button-2>
- event gen .b.f <ButtonRelease-2>
- event gen .b.f <Button-1> -x 30 -y 40
- event gen .b.f <Button-1> -x 30 -y 30
- event gen .b.f <ButtonRelease-1>
- set x
-} 0
-test bind-15.19 {MatchPatterns procedure, checking "nearby"} {
- setup
- bind .b.f <Double-1> {set x 1}
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Button-1> -x 30 -y 40
+ event generate .t.f <Button-1> -x 30 -y 30
+ event generate .t.f <ButtonRelease-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {0}
+test bind-15.19 {MatchPatterns procedure, checking "nearby"} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-1> {set x 1}
set x 0
- event gen .b.f <Button-2>
- event gen .b.f <ButtonRelease-2>
- event gen .b.f <Button-1> -x 30 -y 40
- event gen .b.f <Button-1> -x 30 -y 50
- event gen .b.f <ButtonRelease-1>
- set x
-} 0
-test bind-15.20 {MatchPatterns procedure, checking "nearby"} {
- setup
- bind .b.f <Double-1> {set x 1}
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Button-1> -x 30 -y 40
+ event generate .t.f <Button-1> -x 30 -y 50
+ event generate .t.f <ButtonRelease-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {0}
+test bind-15.20 {MatchPatterns procedure, checking "nearby"} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-1> {set x 1}
set x 0
- event gen .b.f <Button-2>
- event gen .b.f <ButtonRelease-2>
- event gen .b.f <Button-1> -time 300
- event gen .b.f <Button-1> -time 700
- event gen .b.f <ButtonRelease-1>
- set x
-} 1
-test bind-15.21 {MatchPatterns procedure, checking "nearby"} {
- setup
- bind .b.f <Double-1> {set x 1}
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Button-1> -time 300
+ event generate .t.f <Button-1> -time 700
+ event generate .t.f <ButtonRelease-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.21 {MatchPatterns procedure, checking "nearby"} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-1> {set x 1}
set x 0
- event gen .b.f <Button-2>
- event gen .b.f <ButtonRelease-2>
- event gen .b.f <Button-1> -time 300
- event gen .b.f <Button-1> -time 900
- event gen .b.f <ButtonRelease-1>
- set x
-} 0
-test bind-15.22 {MatchPatterns procedure, time wrap-around} {
- setup
- bind .b.f <Double-1> {set x 1}
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Button-1> -time 300
+ event generate .t.f <Button-1> -time 900
+ event generate .t.f <ButtonRelease-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {0}
+test bind-15.22 {MatchPatterns procedure, time wrap-around} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-1> {set x 1}
set x 0
- event gen .b.f <Button-1> -time [expr -100]
- event gen .b.f <Button-1> -time 200
- event gen .b.f <ButtonRelease-1>
- set x
-} 1
-test bind-15.23 {MatchPatterns procedure, time wrap-around} {
- setup
- bind .b.f <Double-1> {set x 1}
+ event generate .t.f <Button-1> -time [expr -100]
+ event generate .t.f <Button-1> -time 200
+ event generate .t.f <ButtonRelease-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.23 {MatchPatterns procedure, time wrap-around} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Double-1> {set x 1}
set x 0
- event gen .b.f <Button-1> -time -100
- event gen .b.f <Button-1> -time 500
- event gen .b.f <ButtonRelease-1>
- set x
-} 0
-test bind-15.24 {MatchPatterns procedure, virtual event} {
- setup
- event add <<Paste>> <Button-1>
- bind .b.f <<Paste>> {lappend x paste}
+ event generate .t.f <Button-1> -time -100
+ event generate .t.f <Button-1> -time 500
+ event generate .t.f <ButtonRelease-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {0}
+
+test bind-15.24 {MatchPatterns procedure, virtual event} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- event gen .b.f <Button-1>
- event gen .b.f <ButtonRelease-1>
+} -body {
+ event add <<Paste>> <Button-1>
+ bind .t.f <<Paste>> {lappend x paste}
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
set x
-} {paste}
-test bind-15.25 {MatchPatterns procedure, reject a virtual event} {
- setup
- event add <<Paste>> <Shift-Button-1>
- bind .b.f <<Paste>> {lappend x paste}
+} -cleanup {
+ destroy .t.f
+ event delete <<Paste>> <Button-1>
+} -result {paste}
+test bind-15.25 {MatchPatterns procedure, reject a virtual event} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- event gen .b.f <Button-1>
- event gen .b.f <ButtonRelease-1>
+} -body {
+ event add <<Paste>> <Shift-Button-1>
+ bind .t.f <<Paste>> {lappend x paste}
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
set x
-} {}
-test bind-15.26 {MatchPatterns procedure, reject a virtual event} {
- setup
+} -cleanup {
+ destroy .t.f
+ event delete <<Paste>> <Shift-Button-1>
+} -result {}
+test bind-15.26 {MatchPatterns procedure, reject a virtual event} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
event add <<V1>> <Button>
event add <<V2>> <Button-1>
event add <<V3>> <Shift-Button-1>
- bind .b.f <<V2>> "lappend x V2%#"
- set x {}
- event gen .b.f <Button> -serial 101
- event gen .b.f <Button-1> -serial 102
- event gen .b.f <Shift-Button-1> -serial 103
- event gen .b.f <ButtonRelease-1>
- bind .b.f <Shift-Button-1> "lappend x Shift-Button-1"
- event gen .b.f <Button> -serial 104
- event gen .b.f <Button-1> -serial 105
- event gen .b.f <Shift-Button-1> -serial 106
- event gen .b.f <ButtonRelease-1>
- set x
-} {V2102 V2103 V2105 Shift-Button-1}
-test bind-15.27 {MatchPatterns procedure, conflict resolution} {
- setup
- bind .b.f <KeyPress> {set x 0}
- bind .b.f a {set x 1}
- set x none
- event gen .b.f <Key-a>
+ bind .t.f <<V2>> "lappend x V2%#"
+ event generate .t.f <Button> -serial 101
+ event generate .t.f <Button-1> -serial 102
+ event generate .t.f <Shift-Button-1> -serial 103
+ event generate .t.f <ButtonRelease-1>
+ bind .t.f <Shift-Button-1> "lappend x Shift-Button-1"
+ event generate .t.f <Button> -serial 104
+ event generate .t.f <Button-1> -serial 105
+ event generate .t.f <Shift-Button-1> -serial 106
+ event generate .t.f <ButtonRelease-1>
set x
-} 1
-test bind-15.28 {MatchPatterns procedure, conflict resolution} {
- setup
- bind .b.f <KeyPress> {set x 0}
- bind .b.f a {set x 1}
- set x none
- event gen .b.f <Key-b>
- set x
-} 0
-test bind-15.29 {MatchPatterns procedure, conflict resolution} {
- setup
- bind .b.f <KeyPress> {lappend x 0}
- bind .b.f a {lappend x 1}
- bind .b.f ba {lappend x 2}
+} -cleanup {
+ destroy .t.f
+ event delete <<V1>> <Button>
+ event delete <<V2>> <Button-1>
+ event delete <<V3>> <Shift-Button-1>
+} -result {V2102 V2103 V2105 Shift-Button-1}
+test bind-15.27 {MatchPatterns procedure, conflict resolution} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <KeyPress> {set x 0}
+ bind .t.f 1 {set x 1}
set x none
- event gen .b.f <Key-b>
- event gen .b.f <KeyRelease-b>
- event gen .b.f <Key-a>
- set x
-} {none 0 2}
-test bind-15.30 {MatchPatterns procedure, conflict resolution} {
- setup
- bind .b.f <ButtonPress> {set x 0}
- bind .b.f <1> {set x 1}
+ event generate .t.f <Key-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.28 {MatchPatterns procedure, conflict resolution} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <KeyPress> {set x 0}
+ bind .t.f 1 {set x 1}
set x none
- event gen .b.f <Button-1>
- event gen .b.f <ButtonRelease-1>
- set x
-} 1
-test bind-15.31 {MatchPatterns procedure, conflict resolution} {
- setup
- bind .b.f <M1-Key> {set x 0}
- bind .b.f <M2-Key> {set x 1}
+ event generate .t.f <Key-2>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {0}
+test bind-15.29 {MatchPatterns procedure, conflict resolution} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <KeyPress> {lappend x 0}
+ bind .t.f 1 {lappend x 1}
+ bind .t.f 21 {lappend x 2}
set x none
- event gen .b.f <Key-a> -state 0x18
+ event generate .t.f <Key-2>
+ event generate .t.f <KeyRelease-2>
+ event generate .t.f <Key-1>
set x
-} 1
-test bind-15.32 {MatchPatterns procedure, conflict resolution} {
- setup
- bind .b.f <M2-Key> {set x 0}
- bind .b.f <M1-Key> {set x 1}
+} -cleanup {
+ destroy .t.f
+} -result {none 0 2}
+test bind-15.30 {MatchPatterns procedure, conflict resolution} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <ButtonPress> {set x 0}
+ bind .t.f <1> {set x 1}
set x none
- event gen .b.f <Key-a> -state 0x18
- set x
-} 1
-test bind-15.33 {MatchPatterns procedure, conflict resolution} {
- setup
- bind .b.f <1> {lappend x single}
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.31 {MatchPatterns procedure, conflict resolution} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <M1-Key> {set x 0}
+ bind .t.f <M2-Key> {set x 1}
+ event generate .t.f <Key-a> -state 0x18
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.32 {MatchPatterns procedure, conflict resolution} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <M2-Key> {set x 0}
+ bind .t.f <M1-Key> {set x 1}
+ set x none
+ event generate .t.f <Key-a> -state 0x18
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-15.33 {MatchPatterns procedure, conflict resolution} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <1> {lappend x single}
bind Test <1> {lappend x single(Test)}
bind Test <Double-1> {lappend x double(Test)}
- set x {}
- event gen .b.f <Button-1>
- event gen .b.f <Button-1>
- event gen .b.f <Button-1>
- event gen .b.f <ButtonRelease-1>
+ event generate .t.f <Button-1>
+ event generate .t.f <Button-1>
+ event generate .t.f <Button-1>
+ event generate .t.f <ButtonRelease-1>
set x
-} {single single(Test) single double(Test) single double(Test)}
-foreach i [bind Test] {
- bind Test $i {}
-}
-test bind-16.1 {ExpandPercents procedure} {
- setup
- bind .b.f <Enter> {set x abcd}
+} -cleanup {
+ destroy .t.f
+ bind Test <1> {}
+ bind Test <Double-1> {}
+} -result {single single(Test) single double(Test) single double(Test)}
+
+
+test bind-16.1 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x abcd}
set x none
- event gen .b.f <Enter>
+ event generate .t.f <Enter>
set x
-} abcd
-test bind-16.2 {ExpandPercents procedure} {
- setup
- bind .b.f <Enter> {set x %#}
+} -cleanup {
+ destroy .t.f
+} -result {abcd}
+test bind-16.2 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x %#}
set x none
- event gen .b.f <Enter> -serial 1234
+ event generate .t.f <Enter> -serial 1234
set x
-} 1234
-test bind-16.3 {ExpandPercents procedure} {
- setup
- bind .b.f <Configure> {set x %a}
+} -cleanup {
+ destroy .t.f
+} -result {1234}
+test bind-16.3 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Configure> {set x %a}
set x none
- event gen .b.f <Configure> -above .b -window .b.f
+ event generate .t.f <Configure> -above .t -window .t.f
set x
-} [winfo id .b]
-test bind-16.4 {ExpandPercents procedure} {
- setup
- bind .b.f <Button> {set x %b}
+} -cleanup {
+ destroy .t.f
+} -result [winfo id .t]
+test bind-16.4 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Button> {set x %b}
set x none
- event gen .b.f <Button-3>
- event gen .b.f <ButtonRelease-3>
+ event generate .t.f <Button-3>
+ event generate .t.f <ButtonRelease-3>
set x
-} 3
-test bind-16.5 {ExpandPercents procedure} {
- setup
- bind .b.f <Expose> {set x %c}
+} -cleanup {
+ destroy .t.f
+} -result {3}
+test bind-16.5 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Expose> {set x %c}
set x none
- event gen .b.f <Expose> -count 47
+ event generate .t.f <Expose> -count 47
set x
-} 47
-test bind-16.6 {ExpandPercents procedure} {
- setup
- bind .b.f <Enter> {set x %d}
+} -cleanup {
+ destroy .t.f
+} -result {47}
+test bind-16.6 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x %d}
set x none
- event gen .b.f <Enter> -detail NotifyAncestor
+ event generate .t.f <Enter> -detail NotifyAncestor
set x
-} NotifyAncestor
-test bind-16.7 {ExpandPercents procedure} {
- setup
- bind .b.f <Enter> {set x %d}
+} -cleanup {
+ destroy .t.f
+} -result {NotifyAncestor}
+test bind-16.7 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x %d}
set x none
- event gen .b.f <Enter> -detail NotifyVirtual
+ event generate .t.f <Enter> -detail NotifyVirtual
set x
-} NotifyVirtual
-test bind-16.8 {ExpandPercents procedure} {
- setup
- bind .b.f <Enter> {set x %d}
+} -cleanup {
+ destroy .t.f
+} -result {NotifyVirtual}
+test bind-16.8 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x %d}
set x none
- event gen .b.f <Enter> -detail NotifyNonlinear
+ event generate .t.f <Enter> -detail NotifyNonlinear
set x
-} NotifyNonlinear
-test bind-16.9 {ExpandPercents procedure} {
- setup
- bind .b.f <Enter> {set x %d}
+} -cleanup {
+ destroy .t.f
+} -result {NotifyNonlinear}
+test bind-16.9 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x %d}
set x none
- event gen .b.f <Enter> -detail NotifyNonlinearVirtual
+ event generate .t.f <Enter> -detail NotifyNonlinearVirtual
set x
-} NotifyNonlinearVirtual
-test bind-16.10 {ExpandPercents procedure} {
- setup
- bind .b.f <Enter> {set x %d}
+} -cleanup {
+ destroy .t.f
+} -result {NotifyNonlinearVirtual}
+test bind-16.10 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x %d}
set x none
- event gen .b.f <Enter> -detail NotifyPointer
+ event generate .t.f <Enter> -detail NotifyPointer
set x
-} NotifyPointer
-test bind-16.11 {ExpandPercents procedure} {
- setup
- bind .b.f <Enter> {set x %d}
+} -cleanup {
+ destroy .t.f
+} -result {NotifyPointer}
+test bind-16.11 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x %d}
set x none
- event gen .b.f <Enter> -detail NotifyPointerRoot
+ event generate .t.f <Enter> -detail NotifyPointerRoot
set x
-} NotifyPointerRoot
-test bind-16.12 {ExpandPercents procedure} {
- setup
- bind .b.f <Enter> {set x %d}
+} -cleanup {
+ destroy .t.f
+} -result {NotifyPointerRoot}
+test bind-16.12 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x %d}
set x none
- event gen .b.f <Enter> -detail NotifyDetailNone
+ event generate .t.f <Enter> -detail NotifyDetailNone
set x
-} NotifyDetailNone
-test bind-16.13 {ExpandPercents procedure} {
- setup
- bind .b.f <Enter> {set x %f}
+} -cleanup {
+ destroy .t.f
+} -result {NotifyDetailNone}
+test bind-16.13 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x %f}
set x none
- event gen .b.f <Enter> -focus 1
- set x
-} 1
-test bind-16.14 {ExpandPercents procedure} {
- setup
- bind .b.f <Expose> {set x "%x %y %w %h"}
+ event generate .t.f <Enter> -focus 1
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-16.14 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Expose> {set x "%x %y %w %h"}
set x none
- event gen .b.f <Expose> -x 24 -y 18 -width 147 -height 61
+ event generate .t.f <Expose> -x 24 -y 18 -width 147 -height 61
set x
-} {24 18 147 61}
-test bind-16.15 {ExpandPercents procedure} {
- setup
- bind .b.f <Configure> {set x "%x %y %w %h"}
+} -cleanup {
+ destroy .t.f
+} -result {24 18 147 61}
+test bind-16.15 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Configure> {set x "%x %y %w %h"}
set x none
- event gen .b.f <Configure> -x 24 -y 18 -width 147 -height 61 -window .b.f
+ event generate .t.f <Configure> -x 24 -y 18 -width 147 -height 61 -window .t.f
set x
-} {24 18 147 61}
-test bind-16.16 {ExpandPercents procedure} {
- setup
- bind .b.f <Key> {set x "%k"}
+} -cleanup {
+ destroy .t.f
+} -result {24 18 147 61}
+test bind-16.16 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Key> {set x "%k"}
set x none
- event gen .b.f <Key> -keycode 146
+ event generate .t.f <Key> -keycode 146
set x
-} 146
-test bind-16.17 {ExpandPercents procedure} {
- setup
- bind .b.f <Enter> {set x "%m"}
+} -cleanup {
+ destroy .t.f
+} -result {146}
+test bind-16.17 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x "%m"}
set x none
- event gen .b.f <Enter> -mode NotifyNormal
+ event generate .t.f <Enter> -mode NotifyNormal
set x
-} NotifyNormal
-test bind-16.18 {ExpandPercents procedure} {
- setup
- bind .b.f <Enter> {set x "%m"}
+} -cleanup {
+ destroy .t.f
+} -result {NotifyNormal}
+test bind-16.18 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x "%m"}
set x none
- event gen .b.f <Enter> -mode NotifyGrab
+ event generate .t.f <Enter> -mode NotifyGrab
set x
-} NotifyGrab
-test bind-16.19 {ExpandPercents procedure} {
- setup
- bind .b.f <Enter> {set x "%m"}
+} -cleanup {
+ destroy .t.f
+} -result {NotifyGrab}
+test bind-16.19 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x "%m"}
set x none
- event gen .b.f <Enter> -mode NotifyUngrab
+ event generate .t.f <Enter> -mode NotifyUngrab
set x
-} NotifyUngrab
-test bind-16.20 {ExpandPercents procedure} {
- setup
- bind .b.f <Enter> {set x "%m"}
+} -cleanup {
+ destroy .t.f
+} -result {NotifyUngrab}
+test bind-16.20 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Enter> {set x "%m"}
set x none
- event gen .b.f <Enter> -mode NotifyWhileGrabbed
+ event generate .t.f <Enter> -mode NotifyWhileGrabbed
set x
-} NotifyWhileGrabbed
-test bind-16.21 {ExpandPercents procedure} {
- setup
- bind .b.f <Map> {set x "%o"}
+} -cleanup {
+ destroy .t.f
+} -result {NotifyWhileGrabbed}
+test bind-16.21 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Map> {set x "%o"}
set x none
- event gen .b.f <Map> -override 1 -window .b.f
- set x
-} 1
-test bind-16.22 {ExpandPercents procedure} {
- setup
- bind .b.f <Reparent> {set x "%o"}
+ event generate .t.f <Map> -override 1 -window .t.f
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-16.22 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Reparent> {set x "%o"}
set x none
- event gen .b.f <Reparent> -override true -window .b.f
- set x
-} 1
-test bind-16.23 {ExpandPercents procedure} {
- setup
- bind .b.f <Configure> {set x "%o"}
+ event generate .t.f <Reparent> -override true -window .t.f
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-16.23 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Configure> {set x "%o"}
set x none
- event gen .b.f <Configure> -override 1 -window .b.f
- set x
-} 1
-test bind-16.24 {ExpandPercents procedure} {
- setup
- bind .b.f <Circulate> {set x "%p"}
+ event generate .t.f <Configure> -override 1 -window .t.f
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-16.24 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Circulate> {set x "%p"}
set x none
- event gen .b.f <Circulate> -place PlaceOnTop -window .b.f
+ event generate .t.f <Circulate> -place PlaceOnTop -window .t.f
set x
-} PlaceOnTop
-test bind-16.25 {ExpandPercents procedure} {
- setup
- bind .b.f <Circulate> {set x "%p"}
+} -cleanup {
+ destroy .t.f
+} -result {PlaceOnTop}
+test bind-16.25 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Circulate> {set x "%p"}
set x none
- event gen .b.f <Circulate> -place PlaceOnBottom -window .b.f
+ event generate .t.f <Circulate> -place PlaceOnBottom -window .t.f
set x
-} PlaceOnBottom
-test bind-16.26 {ExpandPercents procedure} {
- setup
- bind .b.f <1> {set x "%s"}
+} -cleanup {
+ destroy .t.f
+} -result {PlaceOnBottom}
+test bind-16.26 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <1> {set x "%s"}
set x none
- event gen .b.f <Button-1> -state 1402
- event gen .b.f <ButtonRelease-1>
+ event generate .t.f <Button-1> -state 1402
+ event generate .t.f <ButtonRelease-1>
set x
-} 1402
-test bind-16.27 {ExpandPercents procedure} {
- setup
- bind .b.f <Enter> {set x "%s"}
+} -cleanup {
+ destroy .t.f
+} -result {1402}
+test bind-16.27 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x "%s"}
set x none
- event gen .b.f <Enter> -state 0x3ff
+ event generate .t.f <Enter> -state 0x3ff
set x
-} 1023
-test bind-16.28 {ExpandPercents procedure} {
- setup
- bind .b.f <Visibility> {set x "%s"}
+} -cleanup {
+ destroy .t.f
+} -result {1023}
+test bind-16.28 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Visibility> {set x "%s"}
set x none
- event gen .b.f <Visibility> -state VisibilityPartiallyObscured
+ event generate .t.f <Visibility> -state VisibilityPartiallyObscured
set x
-} VisibilityPartiallyObscured
-test bind-16.29 {ExpandPercents procedure} {
- setup
- bind .b.f <Visibility> {set x "%s"}
+} -cleanup {
+ destroy .t.f
+} -result {VisibilityPartiallyObscured}
+test bind-16.29 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Visibility> {set x "%s"}
set x none
- event gen .b.f <Visibility> -state VisibilityUnobscured
+ event generate .t.f <Visibility> -state VisibilityUnobscured
set x
-} VisibilityUnobscured
-test bind-16.30 {ExpandPercents procedure} {
- setup
- bind .b.f <Visibility> {set x "%s"}
+} -cleanup {
+ destroy .t.f
+} -result {VisibilityUnobscured}
+test bind-16.30 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Visibility> {set x "%s"}
set x none
- event gen .b.f <Visibility> -state VisibilityFullyObscured
+ event generate .t.f <Visibility> -state VisibilityFullyObscured
set x
-} VisibilityFullyObscured
-test bind-16.31 {ExpandPercents procedure} {
- setup
- bind .b.f <Button> {set x "%t"}
+} -cleanup {
+ destroy .t.f
+} -result {VisibilityFullyObscured}
+test bind-16.31 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Button> {set x "%t"}
set x none
- event gen .b.f <Button> -time 4294
- event gen .b.f <ButtonRelease>
+ event generate .t.f <Button> -time 4294
+ event generate .t.f <ButtonRelease>
set x
-} 4294
-test bind-16.32 {ExpandPercents procedure} {
- setup
- bind .b.f <Button> {set x "%x %y"}
+} -cleanup {
+ destroy .t.f
+} -result {4294}
+test bind-16.32 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Button> {set x "%x %y"}
set x none
- event gen .b.f <Button> -x 881 -y 432
- event gen .b.f <ButtonRelease>
+ event generate .t.f <Button> -x 881 -y 432
+ event generate .t.f <ButtonRelease>
set x
-} {881 432}
-test bind-16.33 {ExpandPercents procedure} {
- setup
- bind .b.f <Reparent> {set x "%x %y"}
+} -cleanup {
+ destroy .t.f
+} -result {881 432}
+test bind-16.33 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Reparent> {set x "%x %y"}
set x none
- event gen .b.f <Reparent> -x 882 -y 431 -window .b.f
+ event generate .t.f <Reparent> -x 882 -y 431 -window .t.f
set x
-} {882 431}
-test bind-16.34 {ExpandPercents procedure} {
- setup
- bind .b.f <Enter> {set x "%x %y"}
+} -cleanup {
+ destroy .t.f
+} -result {882 431}
+test bind-16.34 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x "%x %y"}
set x none
- event gen .b.f <Enter> -x 781 -y 632
- set x
-} {781 632}
-test bind-16.35 {ExpandPercents procedure} {nonPortable} {
- setup
- bind .b.f <Key> {lappend x "%A"}
- set x {}
- event gen .b.f <Key-a>
- event gen .b.f <Key-A> -state 1
- event gen .b.f <Key-Tab>
- event gen .b.f <Key-Return>
- event gen .b.f <Key-F1>
- event gen .b.f <Key-Shift_L>
- event gen .b.f <Key-space>
- event gen .b.f <Key-dollar> -state 1
- event gen .b.f <Key-braceleft> -state 1
- event gen .b.f <Key-Multi_key>
- event gen .b.f <Key-e>
- event gen .b.f <Key-apostrophe>
- set x
-} "a A { } {\r} {{}} {{}} { } {\$} \\\{ {{}} {{}} \u00e9"
-test bind-16.36 {ExpandPercents procedure} {
- setup
- bind .b.f <Configure> {set x "%B"}
+ event generate .t.f <Enter> -x 781 -y 632
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {781 632}
+test bind-16.35 {ExpandPercents procedure} -constraints {
+ nonPortable
+} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> {lappend x "%A"}
+ event generate .t.f <Key-a>
+ event generate .t.f <Key-A> -state 1
+ event generate .t.f <Key-Tab>
+ event generate .t.f <Key-Return>
+ event generate .t.f <Key-F1>
+ event generate .t.f <Key-Shift_L>
+ event generate .t.f <Key-space>
+ event generate .t.f <Key-dollar> -state 1
+ event generate .t.f <Key-braceleft> -state 1
+ event generate .t.f <Key-Multi_key>
+ event generate .t.f <Key-e>
+ event generate .t.f <Key-apostrophe>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {a A { } {\r} {{}} {{}} { } {\$} \\\{ {{}} {{}} \u00e9}
+test bind-16.36 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Configure> {set x "%B"}
set x none
- event gen .b.f <Configure> -borderwidth 24 -window .b.f
+ event generate .t.f <Configure> -borderwidth 24 -window .t.f
set x
-} 24
-test bind-16.37 {ExpandPercents procedure} {
- setup
- bind .b.f <Enter> {set x "%E"}
+} -cleanup {
+ destroy .t.f
+} -result {24}
+test bind-16.37 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Enter> {set x "%E"}
set x none
- event gen .b.f <Enter> -sendevent 1
- set x
-} 1
-test bind-16.38 {ExpandPercents procedure} {nonPortable} {
- setup
- bind .b.f <Key> {lappend x %K}
- set x {}
- event gen .b.f <Key-a>
- event gen .b.f <Key-A> -state 1
- event gen .b.f <Key-Tab>
- event gen .b.f <Key-F1>
- event gen .b.f <Key-Shift_L>
- event gen .b.f <Key-space>
- event gen .b.f <Key-dollar> -state 1
- event gen .b.f <Key-braceleft> -state 1
- set x
-} {a A Tab F1 Shift_L space dollar braceleft}
-test bind-16.39 {ExpandPercents procedure} {
- setup
- bind .b.f <Key> {set x "%N"}
+ event generate .t.f <Enter> -sendevent 1
+ return $x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-16.38 {ExpandPercents procedure} -constraints {
+ nonPortable
+} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> {lappend x %K}
+ event generate .t.f <Key-a>
+ event generate .t.f <Key-A> -state 1
+ event generate .t.f <Key-Tab>
+ event generate .t.f <Key-F1>
+ event generate .t.f <Key-Shift_L>
+ event generate .t.f <Key-space>
+ event generate .t.f <Key-dollar> -state 1
+ event generate .t.f <Key-braceleft> -state 1
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {a A Tab F1 Shift_L space dollar braceleft}
+test bind-16.39 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Key> {set x "%N"}
set x none
- event gen .b.f <Key-a>
+ event generate .t.f <Key-space>
set x
-} 97
-test bind-16.40 {ExpandPercents procedure} {
- setup
- bind .b.f <Key> {set x "%S"}
+} -cleanup {
+ destroy .t.f
+} -result {32}
+test bind-16.40 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Key> {set x "%S"}
set x none
- event gen .b.f <Key-a> -subwindow .b
+ event generate .t.f <Key-space> -subwindow .t
set x
-} [winfo id .b]
-test bind-16.41 {ExpandPercents procedure} {
- setup
- bind .b.f <Key> {set x "%T"}
+} -cleanup {
+ destroy .t.f
+} -result [winfo id .t]
+test bind-16.41 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Key> {set x "%T"}
set x none
- event gen .b.f <Key>
+ event generate .t.f <Key>
set x
-} 2
-test bind-16.42 {ExpandPercents procedure} {
- setup
- bind .b.f <Key> {set x "%W"}
+} -cleanup {
+ destroy .t.f
+} -result {2}
+test bind-16.42 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <Key> {set x "%W"}
set x none
- event gen .b.f <Key>
+ event generate .t.f <Key>
set x
-} .b.f
-test bind-16.43 {ExpandPercents procedure} {
- setup
- bind .b.f <Button> {set x "%X %Y"}
+} -cleanup {
+ destroy .t.f
+} -result {.t.f}
+test bind-16.43 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Button> {set x "%X %Y"}
set x none
- event gen .b.f <Button> -rootx 422 -rooty 13
- event gen .b.f <ButtonRelease>
+ event generate .t.f <Button> -rootx 422 -rooty 13
+ event generate .t.f <ButtonRelease>
set x
-} {422 13}
-test bind-16.44 {ExpandPercents procedure} {
- setup
- bind .b.f <Gravity> {set x "%R %S"}
+} -cleanup {
+ destroy .t.f
+} -result {422 13}
+test bind-16.44 {ExpandPercents procedure} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Gravity> {set x "%R %S"}
set x none
- event gen .b.f <Gravity>
- set x
-} {?? ??}
-
-
-test bind-17.1 {event command} {
- list [catch {event} msg] $msg
-} {1 {wrong # args: should be "event option ?arg?"}}
-test bind-17.2 {event command} {
- list [catch {event xyz} msg] $msg
-} {1 {bad option "xyz": must be add, delete, generate, or info}}
-test bind-17.3 {event command: add} {
- list [catch {event add} msg] $msg
-} {1 {wrong # args: should be "event add virtual sequence ?sequence ...?"}}
-test bind-17.4 {event command: add 1} {
- setup
+ event generate .t.f <Gravity>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {?? ??}
+
+
+test bind-17.1 {event command} -body {
+ event
+} -returnCodes error -result {wrong # args: should be "event option ?arg?"}
+test bind-17.2 {event command} -body {
+ event xyz
+} -returnCodes error -result {bad option "xyz": must be add, delete, generate, or info}
+test bind-17.3 {event command: add} -body {
+ event add
+} -returnCodes error -result {wrong # args: should be "event add virtual sequence ?sequence ...?"}
+test bind-17.4 {event command: add 1} -body {
+ event delete <<Paste>>
event add <<Paste>> <Control-v>
event info <<Paste>>
-} {<Control-Key-v>}
-test bind-17.5 {event command: add 2} {
- setup
+} -cleanup {
+ event delete <<Paste>> <Control-v>
+} -result {<Control-Key-v>}
+test bind-17.5 {event command: add 2} -body {
+ event delete <<Paste>>
event add <<Paste>> <Control-v> <Button-2>
lsort [event info <<Paste>>]
-} {<Button-2> <Control-Key-v>}
-test bind-17.6 {event command: add with error} {
- setup
- list [catch {event add <<Paste>> <Control-v> <Button-2> abc <xyz> <1>} \
- msg] $msg [lsort [event info <<Paste>>]]
-} {1 {bad event type or keysym "xyz"} {<Button-2> <Control-Key-v> abc}}
-test bind-17.7 {event command: delete} {
- list [catch {event delete} msg] $msg
-} {1 {wrong # args: should be "event delete virtual ?sequence sequence ...?"}}
-test bind-17.8 {event command: delete many} {
- setup
+} -cleanup {
+ event delete <<Paste>> <Control-v> <Button-2>
+} -result {<Button-2> <Control-Key-v>}
+
+test bind-17.6 {event command: add with error} -body {
+ event add <<Paste>> <Control-v> <Button-2> abc <xyz> <1>
+} -cleanup {
+ event delete <<Paste>>
+} -returnCodes error -result {bad event type or keysym "xyz"}
+test bind-17.7 {event command: add with error} -body {
+ event delete <<Paste>>
+ catch {event add <<Paste>> <Control-v> <Button-2> abc <xyz> <1>}
+ lsort [event info <<Paste>>]
+} -cleanup {
+ event delete <<Paste>>
+} -result {<Button-2> <Control-Key-v> abc}
+
+test bind-17.8 {event command: delete} -body {
+ event delete
+} -returnCodes error -result {wrong # args: should be "event delete virtual ?sequence ...?"}
+test bind-17.9 {event command: delete many} -body {
+ event delete <<Paste>>
event add <<Paste>> <3> <1> <2> t
event delete <<Paste>> <1> <2>
lsort [event info <<Paste>>]
-} {<Button-3> t}
-test bind-17.9 {event command: delete all} {
- setup
+} -cleanup {
+ event delete <<Paste>> <3> t
+} -result {<Button-3> t}
+test bind-17.10 {event command: delete all} -body {
event add <<Paste>> a b
event delete <<Paste>>
event info <<Paste>>
-} {}
-test bind-17.10 {event command: delete 1} {
- setup
+} -cleanup {
+ event delete <<Paste>> a b
+} -result {}
+test bind-17.11 {event command: delete 1} -body {
+ event delete <<Paste>>
event add <<Paste>> a b c
event delete <<Paste>> b
lsort [event info <<Paste>>]
-} {a c}
-test bind-17.11 {event command: info name} {
- setup
+} -cleanup {
+ event delete <<Paste>>
+} -result {a c}
+test bind-17.12 {event command: info name} -body {
+ event delete <<Paste>>
event add <<Paste>> a b c
lsort [event info <<Paste>>]
-} {a b c}
-test bind-17.12 {event command: info all} {
- setup
+} -cleanup {
+ event delete <<Paste>>
+} -result {a b c}
+test bind-17.13 {event command: info all} -body {
+ foreach p [event info] {event delete $p}
event add <<Paste>> a
event add <<Alive>> b
lsort [event info]
-} {<<Alive>> <<Paste>>}
-test bind-17.13 {event command: info error} {
- list [catch {event info <<Paste>> <Control-v>} msg] $msg
-} {1 {wrong # args: should be "event info ?virtual?"}}
-test bind-17.14 {event command: generate} {
- list [catch {event generate} msg] $msg
-} {1 {wrong # args: should be "event generate window event ?options?"}}
-test bind-17.15 {event command: generate} {
- setup
- bind .b.f <1> "lappend x 1"
- set x {}
- event generate .b.f <1>
- set x
-} {1}
-test bind-17.16 {event command: generate} {
- list [catch {event generate .b.f <xyz>} msg] $msg
-} {1 {bad event type or keysym "xyz"}}
-test bind-17.17 {event command} {
- list [catch {event foo} msg] $msg
-} {1 {bad option "foo": must be add, delete, generate, or info}}
-
-test bind-18.1 {CreateVirtualEvent procedure: GetVirtualEventUid} {
- list [catch {event add asd <Ctrl-v>} msg] $msg
-} {1 {virtual event "asd" is badly formed}}
-test bind-18.2 {CreateVirtualEvent procedure: FindSequence} {
- list [catch {event add <<asd>> <Ctrl-v>} msg] $msg
-} {1 {bad event type or keysym "Ctrl"}}
-test bind-18.3 {CreateVirtualEvent procedure: new physical} {
- setup
+} -cleanup {
+ event delete <<Paste>>
+ event delete <<Alive>>
+} -result {<<Alive>> <<Paste>>}
+
+test bind-17.14 {event command: info error} -body {
+ event info <<Paste>> <Control-v>
+} -returnCodes error -result {wrong # args: should be "event info ?virtual?"}
+test bind-17.15 {event command: generate} -body {
+ event generate
+} -returnCodes error -result {wrong # args: should be "event generate window event ?-option value ...?"}
+
+test bind-17.16 {event command: generate} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+} -body {
+ bind .t.f <1> "lappend x 1"
+ event generate .t.f <1>
+ set x
+} -cleanup {
+ destroy .t.f
+} -result {1}
+test bind-17.17 {event command: generate} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ event generate .t.f <xyz>
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {bad event type or keysym "xyz"}
+test bind-17.18 {event command} -body {
+ event foo
+} -returnCodes error -result {bad option "foo": must be add, delete, generate, or info}
+
+
+test bind-18.1 {CreateVirtualEvent procedure: GetVirtualEventUid} -body {
+ event add asd <Ctrl-v>
+} -returnCodes error -result {virtual event "asd" is badly formed}
+test bind-18.2 {CreateVirtualEvent procedure: FindSequence} -body {
+ event add <<asd>> <Ctrl-v>
+} -returnCodes error -result {bad event type or keysym "Ctrl"}
+test bind-18.3 {CreateVirtualEvent procedure: new physical} -body {
+ event delete <<xyz>>
event add <<xyz>> <Control-v>
event info <<xyz>>
-} {<Control-Key-v>}
-test bind-18.4 {CreateVirtualEvent procedure: duplicate physical} {
- setup
+} -cleanup {
+ event delete <<xyz>>
+} -result {<Control-Key-v>}
+test bind-18.4 {CreateVirtualEvent procedure: duplicate physical} -body {
+ event delete <<xyz>>
event add <<xyz>> <Control-v>
event add <<xyz>> <Control-v>
event info <<xyz>>
-} {<Control-Key-v>}
-test bind-18.5 {CreateVirtualEvent procedure: existing physical} {
- setup
+} -cleanup {
+ event delete <<xyz>>
+} -result {<Control-Key-v>}
+test bind-18.5 {CreateVirtualEvent procedure: existing physical} -body {
+ foreach p [event info] {event delete $p}
event add <<xyz>> <Control-v>
event add <<abc>> <Control-v>
list [lsort [event info]] [event info <<xyz>>] [event info <<abc>>]
-} {{<<abc>> <<xyz>>} <Control-Key-v> <Control-Key-v>}
-test bind-18.6 {CreateVirtualEvent procedure: new virtual} {
- setup
+} -cleanup {
+ event delete <<xyz>>
+ event delete <<abc>>
+} -result {{<<abc>> <<xyz>>} <Control-Key-v> <Control-Key-v>}
+test bind-18.6 {CreateVirtualEvent procedure: new virtual} -body {
+ foreach p [event info] {event delete $p}
event add <<xyz>> <Control-v>
list [event info] [event info <<xyz>>]
-} {<<xyz>> <Control-Key-v>}
-test bind-18.7 {CreateVirtualEvent procedure: existing virtual} {
- setup
+} -cleanup {
+ event delete <<abc>>
+} -result {<<xyz>> <Control-Key-v>}
+test bind-18.7 {CreateVirtualEvent procedure: existing virtual} -body {
+ foreach p [event info] {event delete $p}
event add <<xyz>> <Control-v>
event add <<xyz>> <Button-2>
list [event info] [lsort [event info <<xyz>>]]
-} {<<xyz>> {<Button-2> <Control-Key-v>}}
+} -cleanup {
+ event delete <<xyz>>
+} -result {<<xyz>> {<Button-2> <Control-Key-v>}}
-test bind-19.1 {DeleteVirtualEvent procedure: GetVirtualEventUid} {
- list [catch {event add xyz {}} msg] $msg
-} {1 {virtual event "xyz" is badly formed}}
-test bind-19.2 {DeleteVirtualEvent procedure: non-existent virtual} {
- setup
+test bind-19.1 {DeleteVirtualEvent procedure: GetVirtualEventUid} -body {
+ event add xyz {}
+} -returnCodes error -result {virtual event "xyz" is badly formed}
+test bind-19.2 {DeleteVirtualEvent procedure: non-existent virtual} -setup {
+ foreach p [event info] {event delete $p}
+} -body {
event delete <<xyz>>
event info
-} {}
-test bind-19.3 {DeleteVirtualEvent procedure: delete 1} {
- setup
+} -result {}
+test bind-19.3 {DeleteVirtualEvent procedure: delete 1} -setup {
+ event delete <<xyz>>
+} -body {
event add <<xyz>> <Control-v>
event delete <<xyz>> <Control-v>
event info <<xyz>>
-} {}
-test bind-19.4 {DeleteVirtualEvent procedure: delete 1, not owned} {
- setup
+} -result {}
+test bind-19.4 {DeleteVirtualEvent procedure: delete 1, not owned} -setup {
+ event delete <<xyz>>
+} -body {
event add <<xyz>> <Control-v>
event delete <<xyz>> <Button-1>
event info <<xyz>>
-} {<Control-Key-v>}
-test bind-19.5 {DeleteVirtualEvent procedure: delete 1, badly formed} {
- setup
+} -result {<Control-Key-v>}
+test bind-19.5 {DeleteVirtualEvent procedure: delete 1, badly formed} -body {
event add <<xyz>> <Control-v>
- list [catch {event delete <<xyz>> <xyz>} msg] $msg
-} {1 {bad event type or keysym "xyz"}}
-test bind-19.6 {DeleteVirtualEvent procedure: delete 1, badly formed} {
- setup
+ event delete <<xyz>> <xyz>
+} -cleanup {
+ event delete <<xyz>>
+} -returnCodes error -result {bad event type or keysym "xyz"}
+test bind-19.6 {DeleteVirtualEvent procedure: delete 1, badly formed} -body {
event add <<xyz>> <Control-v>
- list [catch {event delete <<xyz>> <<Paste>>} msg] $msg
-} {1 {virtual event not allowed in definition of another virtual event}}
-test bind-19.7 {DeleteVirtualEvent procedure: owns 1, delete all} {
- setup
+ event delete <<xyz>> <<Paste>>
+} -cleanup {
+ event delete <<xyz>>
+} -returnCodes error -result {virtual event not allowed in definition of another virtual event}
+test bind-19.7 {DeleteVirtualEvent procedure: owns 1, delete all} -body {
+ foreach p [event info] {event delete $p}
event add <<xyz>> <Control-v>
event delete <<xyz>>
event info
-} {}
-test bind-19.8 {DeleteVirtualEvent procedure: owns 1, delete 1} {
- setup
+} -result {}
+test bind-19.8 {DeleteVirtualEvent procedure: owns 1, delete 1} -body {
+ foreach p [event info] {event delete $p}
event add <<xyz>> <Control-v>
event delete <<xyz>> <Control-v>
event info
-} {}
-test bind-19.9 {DeleteVirtualEvent procedure: owns many, delete all} {
- setup
+} -result {}
+test bind-19.9 {DeleteVirtualEvent procedure: owns many, delete all} -body {
+ foreach p [event info] {event delete $p}
event add <<xyz>> <Control-v> <Control-w> <Control-x>
event delete <<xyz>>
event info
-} {}
-test bind-19.10 {DeleteVirtualEvent procedure: owns many, delete 1} {
- setup
+} -result {}
+test bind-19.10 {DeleteVirtualEvent procedure: owns many, delete 1} -body {
+ event delete <<xyz>>
event add <<xyz>> <Control-v> <Control-w> <Control-x>
event delete <<xyz>> <Control-w>
lsort [event info <<xyz>>]
-} {<Control-Key-v> <Control-Key-x>}
-test bind-19.11 {DeleteVirtualEvent procedure: owned by 1, only} {
- setup
- event add <<xyz>> <Button-2>
- bind .b.f <<xyz>> {lappend x %#}
+} -cleanup {
+ event delete <<xyz>>
+} -result {<Control-Key-v> <Control-Key-x>}
+test bind-19.11 {DeleteVirtualEvent procedure: owned by 1, only} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- event gen .b.f <Button-2> -serial 101
- event gen .b.f <ButtonRelease-2>
event delete <<xyz>>
- event gen .b.f <Button-2> -serial 102
- event gen .b.f <ButtonRelease-2>
+} -body {
+ event add <<xyz>> <Button-2>
+ bind .t.f <<xyz>> {lappend x %#}
+ event generate .t.f <Button-2> -serial 101
+ event generate .t.f <ButtonRelease-2>
+ event delete <<xyz>>
+ event generate .t.f <Button-2> -serial 102
+ event generate .t.f <ButtonRelease-2>
set x
-} {101}
-test bind-19.12 {DeleteVirtualEvent procedure: owned by 1, first in chain} {
- setup
+} -cleanup {
+ destroy .t.f
+} -result {101}
+test bind-19.12 {DeleteVirtualEvent procedure: owned by 1, first in chain} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+ event delete <<xyz>>
+ event delete <<abc>>
+} -body {
event add <<abc>> <Control-Button-2>
event add <<xyz>> <Button-2>
- bind .b.f <<xyz>> {lappend x xyz}
- bind .b.f <<abc>> {lappend x abc}
- set x {}
- event gen .b.f <Button-2>
- event gen .b.f <ButtonRelease-2>
- event gen .b.f <Control-Button-2>
- event gen .b.f <Control-ButtonRelease-2>
+ bind .t.f <<xyz>> {lappend x xyz}
+ bind .t.f <<abc>> {lappend x abc}
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Control-Button-2>
+ event generate .t.f <Control-ButtonRelease-2>
event delete <<xyz>>
- event gen .b.f <Button-2>
- event gen .b.f <ButtonRelease-2>
- event gen .b.f <Control-Button-2>
- event gen .b.f <Control-ButtonRelease-2>
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Control-Button-2>
+ event generate .t.f <Control-ButtonRelease-2>
list $x [event info <<abc>>]
-} {{xyz abc abc} <Control-Button-2>}
-test bind-19.13 {DeleteVirtualEvent procedure: owned by 1, second in chain} {
- setup
+} -cleanup {
+ destroy .t.f
+ event delete <<abc>>
+} -result {{xyz abc abc} <Control-Button-2>}
+test bind-19.13 {DeleteVirtualEvent procedure: owned by 1, second in chain} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+ event delete <<def>>
+ event delete <<xyz>>
+ event delete <<abc>>
+} -body {
event add <<def>> <Shift-Button-2>
event add <<xyz>> <Button-2>
event add <<abc>> <Control-Button-2>
- bind .b.f <<xyz>> {lappend x xyz}
- bind .b.f <<abc>> {lappend x abc}
- bind .b.f <<def>> {lappend x def}
- set x {}
- event gen .b.f <Button-2>
- event gen .b.f <ButtonRelease-2>
- event gen .b.f <Control-Button-2>
- event gen .b.f <Control-ButtonRelease-2>
- event gen .b.f <Shift-Button-2>
- event gen .b.f <Shift-ButtonRelease-2>
+ bind .t.f <<xyz>> {lappend x xyz}
+ bind .t.f <<abc>> {lappend x abc}
+ bind .t.f <<def>> {lappend x def}
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Control-Button-2>
+ event generate .t.f <Control-ButtonRelease-2>
+ event generate .t.f <Shift-Button-2>
+ event generate .t.f <Shift-ButtonRelease-2>
event delete <<xyz>>
- event gen .b.f <Button-2>
- event gen .b.f <Control-Button-2>
- event gen .b.f <Shift-Button-2>
- event gen .b.f <ButtonRelease-2>
- event gen .b.f <Control-ButtonRelease-2>
- event gen .b.f <Shift-ButtonRelease-2>
+ event generate .t.f <Button-2>
+ event generate .t.f <Control-Button-2>
+ event generate .t.f <Shift-Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Control-ButtonRelease-2>
+ event generate .t.f <Shift-ButtonRelease-2>
list $x [event info <<def>>] [event info <<xyz>>] [event info <<abc>>]
-} {{xyz abc def abc def} <Shift-Button-2> {} <Control-Button-2>}
-test bind-19.14 {DeleteVirtualEvent procedure: owned by 1, last in chain} {
- setup
+} -cleanup {
+ destroy .t.f
+ event delete <<abc>>
+ event delete <<def>>
+} -result {{xyz abc def abc def} <Shift-Button-2> {} <Control-Button-2>}
+test bind-19.14 {DeleteVirtualEvent procedure: owned by 1, last in chain} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+ set x {}
+ event delete <<def>>
+ event delete <<xyz>>
+ event delete <<abc>>
+} -body {
event add <<xyz>> <Button-2>
event add <<abc>> <Control-Button-2>
event add <<def>> <Shift-Button-2>
- bind .b.f <<xyz>> {lappend x xyz}
- bind .b.f <<abc>> {lappend x abc}
- bind .b.f <<def>> {lappend x def}
- set x {}
- event gen .b.f <Button-2>
- event gen .b.f <ButtonRelease-2>
- event gen .b.f <Control-Button-2>
- event gen .b.f <Control-ButtonRelease-2>
- event gen .b.f <Shift-Button-2>
- event gen .b.f <Shift-ButtonRelease-2>
+ bind .t.f <<xyz>> {lappend x xyz}
+ bind .t.f <<abc>> {lappend x abc}
+ bind .t.f <<def>> {lappend x def}
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Control-Button-2>
+ event generate .t.f <Control-ButtonRelease-2>
+ event generate .t.f <Shift-Button-2>
+ event generate .t.f <Shift-ButtonRelease-2>
event delete <<xyz>>
- event gen .b.f <Button-2>
- event gen .b.f <ButtonRelease-2>
- event gen .b.f <Control-Button-2>
- event gen .b.f <Control-ButtonRelease-2>
- event gen .b.f <Shift-Button-2>
- event gen .b.f <Shift-ButtonRelease-2>
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.f <Control-Button-2>
+ event generate .t.f <Control-ButtonRelease-2>
+ event generate .t.f <Shift-Button-2>
+ event generate .t.f <Shift-ButtonRelease-2>
list $x [event info <<xyz>>] [event info <<abc>>] [event info <<def>>]
-} {{xyz abc def abc def} {} <Control-Button-2> <Shift-Button-2>}
-test bind-19.15 {DeleteVirtualEvent procedure: owned by many, first} {
- setup
- pack [frame .b.g -class Test -width 150 -height 100]
- pack [frame .b.h -class Test -width 150 -height 100]
+} -cleanup {
+ destroy .t.f
+ event delete <<def>>
+ event delete <<abc>>
+} -result {{xyz abc def abc def} {} <Control-Button-2> <Shift-Button-2>}
+test bind-19.15 {DeleteVirtualEvent procedure: owned by many, first} -setup {
+ pack [frame .t.f -class Test -width 150 -height 100]
+ pack [frame .t.g -class Test -width 150 -height 100]
+ pack [frame .t.h -class Test -width 150 -height 100]
+ focus -force .t.f
update
+ set x {}
+ event delete <<def>>
+ event delete <<xyz>>
+ event delete <<abc>>
+} -body {
event add <<xyz>> <Button-2>
event add <<abc>> <Button-2>
event add <<def>> <Button-2>
- bind .b.f <<xyz>> {lappend x xyz}
- bind .b.g <<abc>> {lappend x abc}
- bind .b.h <<def>> {lappend x def}
- set x {}
- event gen .b.f <Button-2>
- event gen .b.f <ButtonRelease-2>
- event gen .b.g <Button-2>
- event gen .b.g <ButtonRelease-2>
- event gen .b.h <Button-2>
- event gen .b.h <ButtonRelease-2>
+ bind .t.f <<xyz>> {lappend x xyz}
+ bind .t.g <<abc>> {lappend x abc}
+ bind .t.h <<def>> {lappend x def}
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.g <Button-2>
+ event generate .t.g <ButtonRelease-2>
+ event generate .t.h <Button-2>
+ event generate .t.h <ButtonRelease-2>
event delete <<xyz>>
- event gen .b.f <Button-2>
- event gen .b.f <ButtonRelease-2>
- event gen .b.g <Button-2>
- event gen .b.g <ButtonRelease-2>
- event gen .b.h <Button-2>
- event gen .b.h <ButtonRelease-2>
- destroy .b.g
- destroy .b.h
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.g <Button-2>
+ event generate .t.g <ButtonRelease-2>
+ event generate .t.h <Button-2>
+ event generate .t.h <ButtonRelease-2>
list $x [event info <<xyz>>] [event info <<abc>>] [event info <<def>>]
-} {{xyz abc def abc def} {} <Button-2> <Button-2>}
-test bind-19.16 {DeleteVirtualEvent procedure: owned by many, middle} {
- setup
- pack [frame .b.g -class Test -width 150 -height 100]
- pack [frame .b.h -class Test -width 150 -height 100]
+} -cleanup {
+ destroy .t.f .t.g .t.h
+ event delete <<def>>
+ event delete <<abc>>
+} -result {{xyz abc def abc def} {} <Button-2> <Button-2>}
+test bind-19.16 {DeleteVirtualEvent procedure: owned by many, middle} -setup {
+ pack [frame .t.f -class Test -width 150 -height 100]
+ pack [frame .t.g -class Test -width 150 -height 100]
+ pack [frame .t.h -class Test -width 150 -height 100]
+ focus -force .t.f
update
+ set x {}
+ event delete <<def>>
+ event delete <<xyz>>
+ event delete <<abc>>
+} -body {
event add <<xyz>> <Button-2>
event add <<abc>> <Button-2>
event add <<def>> <Button-2>
- bind .b.f <<xyz>> {lappend x xyz}
- bind .b.g <<abc>> {lappend x abc}
- bind .b.h <<def>> {lappend x def}
- set x {}
- event gen .b.f <Button-2>
- event gen .b.f <ButtonRelease-2>
- event gen .b.g <Button-2>
- event gen .b.g <ButtonRelease-2>
- event gen .b.h <Button-2>
- event gen .b.h <ButtonRelease-2>
+ bind .t.f <<xyz>> {lappend x xyz}
+ bind .t.g <<abc>> {lappend x abc}
+ bind .t.h <<def>> {lappend x def}
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.g <Button-2>
+ event generate .t.g <ButtonRelease-2>
+ event generate .t.h <Button-2>
+ event generate .t.h <ButtonRelease-2>
event delete <<abc>>
- event gen .b.f <Button-2>
- event gen .b.f <ButtonRelease-2>
- event gen .b.g <Button-2>
- event gen .b.g <ButtonRelease-2>
- event gen .b.h <Button-2>
- event gen .b.h <ButtonRelease-2>
- destroy .b.g
- destroy .b.h
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.g <Button-2>
+ event generate .t.g <ButtonRelease-2>
+ event generate .t.h <Button-2>
+ event generate .t.h <ButtonRelease-2>
list $x [event info <<xyz>>] [event info <<abc>>] [event info <<def>>]
-} {{xyz abc def xyz def} <Button-2> {} <Button-2>}
-test bind-19.17 {DeleteVirtualEvent procedure: owned by many, last} {
- setup
- pack [frame .b.g -class Test -width 150 -height 100]
- pack [frame .b.h -class Test -width 150 -height 100]
+} -cleanup {
+ destroy .t.f .t.g .t.h
+ event delete <<def>>
+ event delete <<xyz>>
+} -result {{xyz abc def xyz def} <Button-2> {} <Button-2>}
+test bind-19.17 {DeleteVirtualEvent procedure: owned by many, last} -setup {
+ pack [frame .t.f -class Test -width 150 -height 100]
+ pack [frame .t.g -class Test -width 150 -height 100]
+ pack [frame .t.h -class Test -width 150 -height 100]
+ focus -force .t.f
update
+ set x {}
+ event delete <<def>>
+ event delete <<xyz>>
+ event delete <<abc>>
+} -body {
event add <<xyz>> <Button-2>
event add <<abc>> <Button-2>
event add <<def>> <Button-2>
- bind .b.f <<xyz>> {lappend x xyz}
- bind .b.g <<abc>> {lappend x abc}
- bind .b.h <<def>> {lappend x def}
- set x {}
- event gen .b.f <Button-2>
- event gen .b.f <ButtonRelease-2>
- event gen .b.g <Button-2>
- event gen .b.g <ButtonRelease-2>
- event gen .b.h <Button-2>
- event gen .b.h <ButtonRelease-2>
+ bind .t.f <<xyz>> {lappend x xyz}
+ bind .t.g <<abc>> {lappend x abc}
+ bind .t.h <<def>> {lappend x def}
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.g <Button-2>
+ event generate .t.g <ButtonRelease-2>
+ event generate .t.h <Button-2>
+ event generate .t.h <ButtonRelease-2>
event delete <<def>>
- event gen .b.f <Button-2>
- event gen .b.f <ButtonRelease-2>
- event gen .b.g <Button-2>
- event gen .b.g <ButtonRelease-2>
- event gen .b.h <Button-2>
- event gen .b.h <ButtonRelease-2>
- destroy .b.g
- destroy .b.h
+ event generate .t.f <Button-2>
+ event generate .t.f <ButtonRelease-2>
+ event generate .t.g <Button-2>
+ event generate .t.g <ButtonRelease-2>
+ event generate .t.h <Button-2>
+ event generate .t.h <ButtonRelease-2>
list $x [event info <<xyz>>] [event info <<abc>>] [event info <<def>>]
-} {{xyz abc def xyz abc} <Button-2> <Button-2> {}}
+} -cleanup {
+ destroy .t.f .t.g .t.h
+ event delete <<xyz>>
+ event delete <<abc>>
+} -result {{xyz abc def xyz abc} <Button-2> <Button-2> {}}
-test bind-20.1 {GetVirtualEvent procedure: GetVirtualEventUid} {
- list [catch {event info asd} msg] $msg
-} {1 {virtual event "asd" is badly formed}}
-test bind-20.2 {GetVirtualEvent procedure: non-existent event} {
+test bind-20.1 {GetVirtualEvent procedure: GetVirtualEventUid} -body {
+ event info asd
+} -returnCodes error -result {virtual event "asd" is badly formed}
+test bind-20.2 {GetVirtualEvent procedure: non-existent event} -body {
+ event delete <<asd>>
event info <<asd>>
-} {}
-test bind-20.3 {GetVirtualEvent procedure: owns 1} {
- setup
+} -result {}
+test bind-20.3 {GetVirtualEvent procedure: owns 1} -setup {
+ event delete <<xyz>>
+} -body {
event add <<xyz>> <Control-Key-v>
event info <<xyz>>
-} {<Control-Key-v>}
-test bind-20.4 {GetVirtualEvent procedure: owns many} {
- setup
+} -cleanup {
+ event delete <<xyz>>
+} -result {<Control-Key-v>}
+test bind-20.4 {GetVirtualEvent procedure: owns many} -setup {
+ event delete <<xyz>>
+} -body {
event add <<xyz>> <Control-v> <Button-2> spack
event info <<xyz>>
-} {<Control-Key-v> <Button-2> spack}
+} -cleanup {
+ event delete <<xyz>>
+} -result {<Control-Key-v> <Button-2> spack}
-test bind-21.1 {GetAllVirtualEvents procedure: no events} {
- setup
+test bind-21.1 {GetAllVirtualEvents procedure: no events} -body {
+ foreach p [event info] {event delete $p}
event info
-} {}
-test bind-21.2 {GetAllVirtualEvents procedure: 1 event} {
- setup
+} -result {}
+test bind-21.2 {GetAllVirtualEvents procedure: 1 event} -body {
+ foreach p [event info] {event delete $p}
event add <<xyz>> <Control-v>
event info
-} {<<xyz>>}
-test bind-21.3 {GetAllVirtualEvents procedure: many events} {
- setup
+} -cleanup {
+ event delete <<xyz>>
+} -result {<<xyz>>}
+test bind-21.3 {GetAllVirtualEvents procedure: many events} -body {
+ foreach p [event info] {event delete $p}
event add <<xyz>> <Control-v>
event add <<xyz>> <Button-2>
event add <<abc>> <Control-v>
event add <<def>> <Key-F6>
lsort [event info]
-} {<<abc>> <<def>> <<xyz>>}
-
-test bind-22.1 {HandleEventGenerate} {
- list [catch {event gen .xyz <Control-v>} msg] $msg
-} {1 {bad window path name ".xyz"}}
-test bind-22.2 {HandleEventGenerate} {
- list [catch {event gen zzz <Control-v>} msg] $msg
-} {1 {bad window name/identifier "zzz"}}
-test bind-22.3 {HandleEventGenerate} {
- list [catch {event gen 47 <Control-v>} msg] $msg
-} {1 {bad window name/identifier "47"}}
-test bind-22.4 {HandleEventGenerate} {
- setup
- bind .b.f <Button> {set x "%s %b"}
- set x {}
- event gen [winfo id .b.f] <Control-Button-1> -state 260
- set x
-} {260 1}
-test bind-22.5 {HandleEventGenerate} {
- list [catch {event gen . <xyz>} msg] $msg
-} {1 {bad event type or keysym "xyz"}}
-test bind-22.6 {HandleEventGenerate} {
- list [catch {event gen . <Double-Button-1>} msg] $msg
-} {1 {Double or Triple modifier not allowed}}
-test bind-22.7 {HandleEventGenerate} {
- list [catch {event gen . xyz} msg] $msg
-} {1 {only one event specification allowed}}
-test bind-22.8 {HandleEventGenerate} {
- list [catch {event gen . <Button> -button} msg] $msg
-} {1 {value for "-button" missing}}
-test bind-22.9 {HandleEventGenerate} {
- setup
- bind .b.f <Button> {set x "%s %b"}
- set x {}
- event gen .b.f <ButtonRelease-1>
- event gen .b.f <ButtonRelease-2>
- event gen .b.f <ButtonRelease-3>
- event gen .b.f <Control-Button-1>
- event gen .b.f <Control-ButtonRelease-1>
- set x
-} {4 1}
-test bind-22.10 {HandleEventGenerate} {
- setup
- bind .b.f <Key> {set x "%s %K"}
- set x {}
- event gen .b.f <Control-Key-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>
}
- setup
- bind .b.f <Button> {error Message2}
+ proc bgerror msg {
+ global x errorInfo
+ set x [list $msg $errorInfo]
+ }
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+ bind .t.f <Button> {error Message2}
set x none
do
update
set x
-} {Message2 {Message2
+} -cleanup {
+ destroy .t.f
+ rename bgerror {}
+ rename do {}
+} -result {Message2 {Message2
while executing
"error Message2"
(command bound to event)}}
-rename bgerror {}
-test bind-31.1 {MouseWheel events} {
- setup
+
+test bind-30.1 {MouseWheel events} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- bind .b.f <MouseWheel> {set x Wheel}
- event gen .b.f <MouseWheel>
+} -body {
+ bind .t.f <MouseWheel> {set x Wheel}
+ event generate .t.f <MouseWheel>
set x
-} {Wheel}
-test bind-31.2 {MouseWheel events} {
- setup
+} -cleanup {
+ destroy .t.f
+} -result {Wheel}
+test bind-30.2 {MouseWheel events} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- bind .b.f <MouseWheel> {set x %D}
- event gen .b.f <MouseWheel> -delta 120
+} -body {
+ bind .t.f <MouseWheel> {set x %D}
+ event generate .t.f <MouseWheel> -delta 120
set x
-} {120}
-test bind-31.3 {MouseWheel events} {
- setup
+} -cleanup {
+ destroy .t.f
+} -result {120}
+test bind-30.3 {MouseWheel events} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- bind .b.f <MouseWheel> {set x "%D %x %y"}
- event gen .b.f <MouseWheel> -delta 240 -x 10 -y 30
+} -body {
+ bind .t.f <MouseWheel> {set x "%D %x %y"}
+ event generate .t.f <MouseWheel> -delta 240 -x 10 -y 30
set x
-} {240 10 30}
+} -cleanup {
+ destroy .t.f
+} -result {240 10 30}
+
-test bind-32.1 {virtual event user_data field - bad generation} {
- setup
- # Check no confusion, since Focus events use %d for something else
- list [catch {event gen .b.f <FocusIn> -data foo} msg] $msg
-} {1 {<FocusIn> event doesn't accept "-data" option}}
-test bind-32.2 {virtual event user_data field - NULL, synch} {
- setup
+test bind-31.1 {virtual event user_data field - bad generation} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
+} -body {
+# Check no confusion, since Focus events use %d for something else
+ event generate .t.f <FocusIn> -data foo
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {<FocusIn> event doesn't accept "-data" option}
+test bind-31.2 {virtual event user_data field - NULL, synch} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- bind .b.f <<TestUserData>> {set x "TestUserData >%d<"}
- event gen .b.f <<TestUserData>>
+} -body {
+ bind .t.f <<TestUserData>> {set x "TestUserData >%d<"}
+ event generate .t.f <<TestUserData>>
set x
-} {TestUserData >{}<}
-test bind-32.3 {virtual event user_data field - shared, synch} {
- setup
+} -cleanup {
+ destroy .t.f
+} -result {TestUserData >{}<}
+test bind-31.3 {virtual event user_data field - shared, synch} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- bind .b.f <<TestUserData>> {set x "TestUserData >%d<"}
- event gen .b.f <<TestUserData>> -data "foo bar"
+} -body {
+ bind .t.f <<TestUserData>> {set x "TestUserData >%d<"}
+ event generate .t.f <<TestUserData>> -data "foo bar"
set x
-} {TestUserData >foo bar<}
-test bind-32.4 {virtual event user_data field - unshared, synch} {
- setup
+} -cleanup {
+ destroy .t.f
+} -result {TestUserData >foo bar<}
+test bind-31.4 {virtual event user_data field - unshared, synch} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- bind .b.f <<TestUserData>> {set x "TestUserData >%d<"}
- event gen .b.f <<TestUserData>> -data [string index abc 1]
+} -body {
+ bind .t.f <<TestUserData>> {set x "TestUserData >%d<"}
+ event generate .t.f <<TestUserData>> -data [string index abc 1]
set x
-} {TestUserData >b<}
+} -cleanup {
+ destroy .t.f
+} -result {TestUserData >b<}
# Note that asynch event handling can only really catch any potential
# extra errors when used in combination with a tool like Purify or
# Valgrind. Such testing is rarely done, but at least any problem with
# reference handling will eventually show up with these tests...
-test bind-32.5 {virtual event user_data field - NULL, asynch} {
- setup
+test bind-31.5 {virtual event user_data field - NULL, asynch} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- bind .b.f <<TestUserData>> {set x "TestUserData >%d<"}
- event gen .b.f <<TestUserData>> -when head
+} -body {
+ bind .t.f <<TestUserData>> {set x "TestUserData >%d<"}
+ event generate .t.f <<TestUserData>> -when head
list $x [update] $x
-} {{} {} {TestUserData >{}<}}
-test bind-32.6 {virtual event user_data field - shared, asynch} {
- setup
+} -cleanup {
+ destroy .t.f
+} -result {{} {} {TestUserData >{}<}}
+test bind-31.6 {virtual event user_data field - shared, asynch} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- bind .b.f <<TestUserData>> {set x "TestUserData >%d<"}
- event gen .b.f <<TestUserData>> -data "foo bar" -when head
+} -body {
+ bind .t.f <<TestUserData>> {set x "TestUserData >%d<"}
+ event generate .t.f <<TestUserData>> -data "foo bar" -when head
list $x [update] $x
-} {{} {} {TestUserData >foo bar<}}
-test bind-32.7 {virtual event user_data field - unshared, asynch} {
- setup
+} -cleanup {
+ destroy .t.f
+} -result {{} {} {TestUserData >foo bar<}}
+test bind-31.7 {virtual event user_data field - unshared, asynch} -setup {
+ frame .t.f -class Test -width 150 -height 100
+ pack .t.f
+ focus -force .t.f
+ update
set x {}
- bind .b.f <<TestUserData>> {set x "TestUserData >%d<"}
- event gen .b.f <<TestUserData>> -data [string index abc 1] -when head
+} -body {
+ bind .t.f <<TestUserData>> {set x "TestUserData >%d<"}
+ event generate .t.f <<TestUserData>> -data [string index abc 1] -when head
list $x [update] $x
-} {{} {} {TestUserData >b<}}
+} -cleanup {
+ destroy .t.f
+} -result {{} {} {TestUserData >b<}}
-destroy .b
# cleanup
cleanupTests
diff --git a/tests/bitmap.test b/tests/bitmap.test
index 6e2255c..80bc114 100644
--- a/tests/bitmap.test
+++ b/tests/bitmap.test
@@ -6,55 +6,71 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
-test bitmap-1.1 {Tk_AllocBitmapFromObj - converting internal reps} testbitmap {
+test bitmap-1.1 {Tk_AllocBitmapFromObj - converting internal reps} -constraints {
+ testbitmap
+} -body {
set x gray25
- lindex $x 0
- destroy .b1
- button .b1 -bitmap $x
+ lindex $x 0
+ button .b -bitmap $x
lindex $x 0
testbitmap gray25
-} {{1 0}}
-test bitmap-1.2 {Tk_AllocBitmapFromObj - discard stale bitmap} testbitmap {
+} -cleanup {
+ destroy .b
+} -result {{1 0}}
+test bitmap-1.2 {Tk_AllocBitmapFromObj - discard stale bitmap} -constraints {
+ testbitmap
+} -setup {
+ set result {}
+} -body {
set x gray25
- destroy .b1 .b2
button .b1 -bitmap $x
destroy .b1
- set result {}
lappend result [testbitmap gray25]
button .b2 -bitmap $x
lappend result [testbitmap gray25]
-} {{} {{1 1}}}
-test bitmap-1.3 {Tk_AllocBitmapFromObj - reuse existing bitmap} testbitmap {
- set x gray25
+} -cleanup {
destroy .b1 .b2
- button .b1 -bitmap $x
+} -result {{} {{1 1}}}
+test bitmap-1.3 {Tk_AllocBitmapFromObj - reuse existing bitmap} -constraints {
+ testbitmap
+} -setup {
set result {}
+} -body {
+ set x gray25
+ button .b1 -bitmap $x
lappend result [testbitmap gray25]
button .b2 -bitmap $x
pack .b1 .b2 -side top
lappend result [testbitmap gray25]
-} {{{1 1}} {{2 1}}}
+} -cleanup {
+ destroy .b1 .b2
+} -result {{{1 1}} {{2 1}}}
-test bitmap-2.1 {Tk_GetBitmap procedure} {
- destroy .b1
- list [catch {button .b1 -bitmap bad_name} msg] $msg
-} {1 {bitmap "bad_name" not defined}}
-test bitmap-2.2 {Tk_GetBitmap procedure} {
- destroy .b1
- list [catch {button .b1 -bitmap @xyzzy} msg] $msg
-} {1 {error reading bitmap file "xyzzy"}}
+test bitmap-2.1 {Tk_GetBitmap procedure} -body {
+ button .b1 -bitmap bad_name
+} -cleanup {
+ destroy .b1
+} -returnCodes error -result {bitmap "bad_name" not defined}
+test bitmap-2.2 {Tk_GetBitmap procedure} -body {
+ button .b1 -bitmap @xyzzy
+} -cleanup {
+ destroy .b1
+} -returnCodes error -result {error reading bitmap file "xyzzy"}
-test bitmap-3.1 {Tk_FreeBitmapFromObj - reference counts} testbitmap {
+test bitmap-3.1 {Tk_FreeBitmapFromObj - reference counts} -constraints {
+ testbitmap
+} -setup {
+ set result {}
+} -body {
set x questhead
- destroy .b1 .b2 .b3
button .b1 -bitmap $x
button .b3 -bitmap $x
button .b2 -bitmap $x
- set result {}
lappend result [testbitmap questhead]
destroy .b1
lappend result [testbitmap questhead]
@@ -62,10 +78,13 @@ test bitmap-3.1 {Tk_FreeBitmapFromObj - reference counts} testbitmap {
lappend result [testbitmap questhead]
destroy .b3
lappend result [testbitmap questhead]
-} {{{3 1}} {{2 1}} {{1 1}} {}}
+} -cleanup {
+ destroy .b1 .b2 .b3 ;# destroying just in case
+} -result {{{3 1}} {{2 1}} {{1 1}} {}}
-test bitmap-4.1 {FreeBitmapObjProc} testbitmap {
- destroy .b
+test bitmap-4.1 {FreeBitmapObjProc} -constraints {
+ testbitmap
+} -body {
set x [format questhead]
button .b -bitmap $x
set y [format questhead]
@@ -81,10 +100,11 @@ test bitmap-4.1 {FreeBitmapObjProc} testbitmap {
destroy .b
lappend result [testbitmap questhead]
set y bogus
- set result
-} {{{1 3}} {{1 2}} {{1 1}} {}}
+ return $result
+} -cleanup {
+ destroy .b
+} -result {{{1 3}} {{1 2}} {{1 1}} {}}
-destroy .t
# cleanup
cleanupTests
diff --git a/tests/border.test b/tests/border.test
index 30aed91..78d0fcd 100644
--- a/tests/border.test
+++ b/tests/border.test
@@ -5,49 +5,60 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
-if {[testConstraint pseudocolor8]} {
- toplevel .t -visual {pseudocolor 8} -colormap new
- wm geom .t +0+0
-}
-
-test border-1.1 {Tk_AllocBorderFromObj - converting internal reps} testborder {
+test border-1.1 {Tk_AllocBorderFromObj - converting internal reps} -constraints {
+ testborder
+} -body {
set x orange
lindex $x 0
- destroy .b1
button .b1 -bg $x -text .b1
lindex $x 0
testborder orange
-} {{1 0}}
-test border-1.3 {Tk_AllocBorderFromObj - discard stale border} testborder {
+} -cleanup {
+ destroy .b1
+} -result {{1 0}}
+test border-1.2 {Tk_AllocBorderFromObj - discard stale border} -constraints {
+ testborder
+} -setup {
+ set result {}
+} -body {
set x orange
- destroy .b1 .b2
button .b1 -bg $x -text First
destroy .b1
- set result {}
lappend result [testborder orange]
button .b2 -bg $x -text Second
lappend result [testborder orange]
-} {{} {{1 1}}}
-test border-1.2 {Tk_AllocBorderFromObj - reuse existing border} testborder {
- set x orange
+} -cleanup {
destroy .b1 .b2
- button .b1 -bg $x -text First
+} -result {{} {{1 1}}}
+test border-1.3 {Tk_AllocBorderFromObj - reuse existing border} -constraints {
+ testborder
+} -setup {
set result {}
+} -body {
+ set x orange
+ button .b1 -bg $x -text First
lappend result [testborder orange]
button .b2 -bg $x -text Second
pack .b1 .b2 -side top
lappend result [testborder orange]
-} {{{1 1}} {{2 1}}}
-test border-1.4 {Tk_AllocBorderFromObj - try other borders in list} {pseudocolor8 testborder} {
+} -cleanup {
+ destroy .b1 .b2
+} -result {{{1 1}} {{2 1}}}
+test border-1.4 {Tk_AllocBorderFromObj - try other borders in list} -constraints {
+ testborder pseudocolor8
+} -setup {
+ toplevel .t -visual {pseudocolor 8} -colormap new
+ wm geom .t +0+0
+ set result {}
+} -body {
set x purple
- destroy .b1 .b2 .t.b
button .b1 -bg $x -text First
pack .b1 -side top
- set result {}
lappend result [testborder purple]
button .t.b -bg $x -text Second
pack .t.b -side top
@@ -55,18 +66,24 @@ test border-1.4 {Tk_AllocBorderFromObj - try other borders in list} {pseudocolor
button .b2 -bg $x -text Third
pack .b2 -side top
lappend result [testborder purple]
-} {{{1 1}} {{1 1} {1 0}} {{1 0} {2 1}}}
+} -cleanup {
+ destroy .b1 .b2 .t
+} -result {{{1 1}} {{1 1} {1 0}} {{1 0} {2 1}}}
-test border-3.1 {Tk_Free3DBorder - reference counts} {pseudocolor8 testborder} {
+test border-2.1 {Tk_Free3DBorder - reference counts} -constraints {
+ testborder pseudocolor8
+} -setup {
+ toplevel .t -visual {pseudocolor 8} -colormap new
+ wm geom .t +0+0
+ set result {}
+} -body {
set x purple
- destroy .b1 .b2 .t.b
button .b1 -bg $x -text First
pack .b1 -side top
button .t.b -bg $x -text Second
pack .t.b -side top
button .b2 -bg $x -text Third
pack .b2 -side top
- set result {}
lappend result [testborder purple]
destroy .b1
lappend result [testborder purple]
@@ -74,11 +91,18 @@ test border-3.1 {Tk_Free3DBorder - reference counts} {pseudocolor8 testborder} {
lappend result [testborder purple]
destroy .t.b
lappend result [testborder purple]
-} {{{1 0} {2 1}} {{1 0} {1 1}} {{1 0}} {}}
-test border-3.4 {Tk_Free3DBorder - unlinking from list} {pseudocolor8 testborder} {
- destroy .b .t.b .t2 .t3
+} -cleanup {
+ destroy .b1 .b2 .t
+} -result {{{1 0} {2 1}} {{1 0} {1 1}} {{1 0}} {}}
+test border-2.2 {Tk_Free3DBorder - unlinking from list} -constraints {
+ testborder pseudocolor8
+} -setup {
+ toplevel .t -visual {pseudocolor 8} -colormap new
+ wm geom .t +0+0
toplevel .t2 -visual {pseudocolor 8} -colormap new
toplevel .t3 -visual {pseudocolor 8} -colormap new
+ set result {}
+} -body {
set x purple
button .b -bg $x -text .b1
button .t.b1 -bg $x -text .t.b1
@@ -90,7 +114,6 @@ test border-3.4 {Tk_Free3DBorder - unlinking from list} {pseudocolor8 testborder
button .t3.b2 -bg $x -text .t3.b2
button .t3.b3 -bg $x -text .t3.b3
button .t3.b4 -bg $x -text .t3.b4
- set result {}
lappend result [testborder purple]
destroy .t2
lappend result [testborder purple]
@@ -100,17 +123,21 @@ test border-3.4 {Tk_Free3DBorder - unlinking from list} {pseudocolor8 testborder
lappend result [testborder purple]
destroy .t
lappend result [testborder purple]
-} {{{4 1} {3 0} {2 0} {1 0}} {{4 1} {2 0} {1 0}} {{4 1} {2 0}} {{2 0}} {}}
+} -cleanup {
+ destroy .b .t2 .t3 .t
+} -result {{{4 1} {3 0} {2 0} {1 0}} {{4 1} {2 0} {1 0}} {{4 1} {2 0}} {{2 0}} {}}
-test border-4.1 {FreeBorderObjProc} testborder {
- destroy .b
+test border-3.1 {FreeBorderObjProc} -constraints {
+ testborder
+} -setup {
+ set result {}
+} -body {
set x [format purple]
button .b -bg $x -text .b1
set y [format purple]
.b configure -bg $y
set z [format purple]
.b configure -bg $z
- set result {}
lappend result [testborder purple]
set x red
lappend result [testborder purple]
@@ -119,42 +146,53 @@ test border-4.1 {FreeBorderObjProc} testborder {
destroy .b
lappend result [testborder purple]
set y bogus
- set result
-} {{{1 3}} {{1 2}} {{1 1}} {}}
+ return $result
+} -cleanup {
+ destroy .b
+} -result {{{1 3}} {{1 2}} {{1 1}} {}}
-catch {destroy .b}
-button .b
-test border-5.1 {Tk_GetReliefFromObj} {
- .b configure -relief flat
+test border-4.1 {Tk_GetReliefFromObj} -body {
+ button .b -relief flat
.b cget -relief
-} {flat}
-test border-5.2 {Tk_GetReliefFromObj} {
- .b configure -relief groove
+} -cleanup {
+ destroy .b
+} -result {flat}
+test border-4.2 {Tk_GetReliefFromObj} -body {
+ button .b -relief groove
.b cget -relief
-} {groove}
-test border-5.3 {Tk_GetReliefFromObj} {
- .b configure -relief raised
+} -cleanup {
+ destroy .b
+} -result {groove}
+test border-4.3 {Tk_GetReliefFromObj} -body {
+ button .b -relief raised
.b cget -relief
-} {raised}
-test border-5.4 {Tk_GetReliefFromObj} {
- .b configure -relief ridge
+} -cleanup {
+ destroy .b
+} -result {raised}
+test border-4.4 {Tk_GetReliefFromObj} -body {
+ button .b -relief ridge
.b cget -relief
-} {ridge}
-test border-5.5 {Tk_GetReliefFromObj} {
- .b configure -relief solid
+} -cleanup {
+ destroy .b
+} -result {ridge}
+test border-4.5 {Tk_GetReliefFromObj} -body {
+ button .b -relief solid
.b cget -relief
-} {solid}
-test border-5.6 {Tk_GetReliefFromObj} {
- .b configure -relief sunken
+} -cleanup {
+ destroy .b
+} -result {solid}
+test border-4.6 {Tk_GetReliefFromObj} -body {
+ button .b -relief sunken
.b cget -relief
-} {sunken}
-test border-5.7 {Tk_GetReliefFromObj - error} {
- list [catch {.b configure -relief upanddown} msg] $msg
-} {1 {bad relief "upanddown": must be flat, groove, raised, ridge, solid, or sunken}}
+} -cleanup {
+ destroy .b
+} -result {sunken}
+test border-4.7 {Tk_GetReliefFromObj - error} -body {
+ button .b -relief upanddown
+} -cleanup {
+ destroy .b
+} -returnCodes error -result {bad relief "upanddown": must be flat, groove, raised, ridge, solid, or sunken}
-if {[testConstraint pseudocolor8]} {
- destroy .t
-}
# cleanup
cleanupTests
diff --git a/tests/busy.test b/tests/busy.test
new file mode 100644
index 0000000..304c2eb
--- /dev/null
+++ b/tests/busy.test
@@ -0,0 +1,477 @@
+# Tests for the tk busy command.
+#
+# This file contains a collection of tests for one or more of the Tk built-in
+# commands. Sourcing this file runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 1998-2000 by Jos Decoster. All rights reserved.
+
+package require tcltest 2.1
+tcltest::configure {*}$argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+# There's currently no way to test the actual grab effect, per se, in an
+# automated test. Therefore, this test suite only covers the interface to the
+# grab command (ie, error messages, etc.)
+
+test busy-1.1 {Tk_BusyObjCmd} -returnCodes error -body {
+ tk busy
+} -result {wrong # args: should be "tk busy options ?arg arg ...?"}
+
+test busy-2.1 {tk busy hold} -returnCodes error -body {
+ tk busy hold
+} -result {wrong # args: should be "tk busy hold window ?option value ...?"}
+test busy-2.2 {tk busy hold root window} -body {
+ tk busy hold .
+ update
+} -cleanup {
+ tk busy forget .
+} -result {}
+test busy-2.3 {tk busy hold root window with shortcut} -body {
+ tk busy .
+ update
+} -cleanup {
+ tk busy forget .
+} -result {}
+test busy-2.4 {tk busy hold nested window} -setup {
+ pack [frame .f]
+} -body {
+ tk busy hold .f
+ update
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {}
+test busy-2.5 {tk busy hold nested window with shortcut} -setup {
+ pack [frame .f]
+} -body {
+ tk busy .f
+ update
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {}
+test busy-2.6 {tk busy hold toplevel window} -setup {
+ toplevel .f
+} -body {
+ tk busy hold .f
+ update
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {}
+test busy-2.7 {tk busy hold toplevel window with shortcut} -setup {
+ toplevel .f
+} -body {
+ tk busy .f
+ update
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {}
+test busy-2.8 {tk busy hold non existing window} -body {
+ tk busy hold .f
+ update
+} -returnCodes error -result {bad window path name ".f"}
+test busy-2.9 {tk busy hold (shortcut) non existing window} -body {
+ tk busy .f
+ update
+} -returnCodes {error} -result {bad window path name ".f"}
+test busy-2.10 {tk busy hold root window with cursor} -body {
+ tk busy hold . -cursor arrow
+ update
+} -cleanup {
+ tk busy forget .
+} -result {}
+test busy-2.11 {tk busy hold (shortcut) root window, cursor} -body {
+ tk busy . -cursor arrow
+ update
+} -cleanup {
+ tk busy forget .
+} -result {}
+test busy-2.12 {tk busy hold root window, invalid cursor} -body {
+ tk busy hold . -cursor nonExistingCursor
+ update
+} -constraints tempNotMac -returnCodes error -cleanup {
+ tk busy forget .
+} -result {bad cursor spec "nonExistingCursor"}
+test busy-2.13 {tk busy hold (shortcut) root window, invalid cursor} -body {
+ tk busy . -cursor nonExistingCursor
+ update
+} -constraints tempNotMac -returnCodes error -cleanup {
+ tk busy forget .
+} -result {bad cursor spec "nonExistingCursor"}
+test busy-2.14 {tk busy hold root window, invalid option} -body {
+ tk busy hold . -invalidOption 1
+ update
+} -constraints tempNotMac -returnCodes error -cleanup {
+ tk busy forget .
+} -result {unknown option "-invalidOption"}
+test busy-2.15 {tk busy hold (shortcut) root window, invalid option} -body {
+ tk busy . -invalidOption 1
+ update
+} -constraints tempNotMac -returnCodes error -cleanup {
+ tk busy forget .
+} -result {unknown option "-invalidOption"}
+
+test busy-3.1 {tk busy cget no window} -returnCodes error -body {
+ tk busy cget
+} -result {wrong # args: should be "tk busy cget window option"}
+test busy-3.2 {tk busy cget no option} -returnCodes error -body {
+ tk busy cget
+} -result {wrong # args: should be "tk busy cget window option"}
+test busy-3.3 {tk busy cget invalid window} -returnCodes error -body {
+ tk busy cget .f -cursor
+} -result {bad window path name ".f"}
+test busy-3.4 {tk busy cget non-busy window} -setup {
+ pack [frame .f]
+} -body {
+ tk busy cget .f -cursor
+} -cleanup {
+ destroy .f
+} -returnCodes error -result {can't find busy window ".f"}
+test busy-3.5 {tk busy cget invalid option} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+} -body {
+ tk busy cget .f -invalidOption
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -returnCodes error -result {unknown option "-invalidOption"}
+test busy-3.6unix {tk busy cget unix} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+} -body {
+ tk busy cget .f -cursor
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {watch} -constraints unix
+test busy-3.6win {tk busy cget win} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+} -body {
+ tk busy cget .f -cursor
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {wait} -constraints win
+test busy-3.7 {tk busy cget unix} -setup {
+ pack [frame .f]
+ tk busy hold .f -cursor hand1
+ update
+} -body {
+ tk busy cget .f -cursor
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {hand1} -constraints tempNotMac
+
+test busy-4.1 {tk busy configure no window} -returnCodes error -body {
+ tk busy configure
+} -result {wrong # args: should be "tk busy configure window ?option? ?value ...?"}
+
+test busy-4.2 {tk busy configure invalid window} -body {
+ tk busy configure .f
+} -returnCodes error -result {bad window path name ".f"}
+
+test busy-4.3 {tk busy configure non-busy window} -setup {
+ pack [frame .f]
+} -body {
+ tk busy configure .f
+} -cleanup {
+ destroy .f
+} -returnCodes error -result {can't find busy window ".f"}
+
+test busy-4.4 {tk busy configure} -constraints {nonwin} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+} -body {
+ tk busy configure .f
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {{-cursor cursor Cursor watch watch}}
+
+test busy-4.4-win {tk busy configure} -constraints {win} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+} -body {
+ tk busy configure .f
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {{-cursor cursor Cursor wait wait}}
+
+test busy-4.5 {tk busy configure} -constraints {nonwin tempNotMac} -setup {
+ pack [frame .f]
+ tk busy hold .f -cursor hand2
+ update
+} -body {
+ tk busy configure .f
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {{-cursor cursor Cursor watch hand2}}
+
+test busy-4.5-win {tk busy configure} -constraints win -setup {
+ pack [frame .f]
+ tk busy hold .f -cursor hand2
+ update
+} -body {
+ tk busy configure .f
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {{-cursor cursor Cursor wait hand2}}
+
+test busy-4.6 {tk busy configure invalid option} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+} -body {
+ tk busy configure .f -invalidOption
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -returnCodes error -result {unknown option "-invalidOption"}
+
+test busy-4.7 {tk busy configure valid option} -constraints {nonwin} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+} -body {
+ tk busy configure .f -cursor
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {-cursor cursor Cursor watch watch}
+
+test busy-4.7-win {tk busy configure valid option} -constraints {win} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+} -body {
+ tk busy configure .f -cursor
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {-cursor cursor Cursor wait wait}
+
+test busy-4.8 {tk busy configure valid option} -constraints {
+ nonwin tempNotMac
+} -setup {
+ pack [frame .f]
+ tk busy hold .f -cursor circle
+ update
+} -body {
+ tk busy configure .f -cursor
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {-cursor cursor Cursor watch circle}
+
+test busy-4.8-win {tk busy configure valid option} -constraints win -setup {
+ pack [frame .f]
+ tk busy hold .f -cursor circle
+ update
+} -body {
+ tk busy configure .f -cursor
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {-cursor cursor Cursor wait circle}
+
+test busy-4.9 {tk busy configure valid option with value} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+} -body {
+ tk busy configure .f -cursor pencil
+ tk busy cget .f -cursor
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {pencil} -constraints tempNotMac
+
+test busy-4.10 {tk busy configure valid option with invalid value} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+} -body {
+ tk busy configure .f -cursor nonExistingCursor
+} -constraints tempNotMac -returnCodes error -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {bad cursor spec "nonExistingCursor"}
+
+test busy-5.1 {tk busy forget} -returnCodes error -body {
+ tk busy forget
+} -result {wrong # args: should be "tk busy forget window"}
+test busy-5.2 {tk busy forget non existing window} -body {
+ tk busy forget .f
+} -returnCodes error -result {bad window path name ".f"}
+test busy-5.3 {tk busy forget non busy window} -setup {
+ pack [frame .f]
+} -body {
+ tk busy forget .f
+} -cleanup {
+ destroy .f
+} -returnCodes error -result {can't find busy window ".f"}
+test busy-5.4 {tk busy forget window} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+} -body {
+ set r [tk busy status .f]
+ tk busy forget .f
+ lappend r [tk busy status .f]
+} -cleanup {
+ destroy .f
+} -result {1 0}
+
+test busy-6.1 {tk busy status} -returnCodes error -body {
+ tk busy status
+} -result {wrong # args: should be "tk busy status window"}
+test busy-6.2 {tk busy status non existing window} -body {
+ tk busy status .f
+} -result {0}
+test busy-6.3 {tk busy status non busy window} -setup {
+ pack [frame .f]
+} -body {
+ tk busy status .f
+} -cleanup {
+ destroy .f
+} -result {0}
+test busy-6.4 {tk busy status busy window} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+} -body {
+ tk busy status .f
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {1}
+test busy-6.5 {tk busy status forgotten busy window} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+ tk busy forget .f
+} -body {
+ tk busy status .f
+} -cleanup {
+ destroy .f
+} -result {0}
+
+test busy-7.1 {tk busy current no busy} -body {
+ tk busy current
+} -result {}
+test busy-7.2 {tk busy current 1 busy} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+} -body {
+ tk busy current
+} -cleanup {
+ tk busy forget .f
+ destroy .f
+} -result {.f}
+test busy-7.3 {tk busy current 2 busy} -setup {
+ pack [frame .f1]
+ pack [frame .f2]
+ tk busy hold .f1
+ tk busy hold .f2
+ update
+} -body {
+ lsort [tk busy current]
+} -cleanup {
+ tk busy forget .f1
+ tk busy forget .f2
+ destroy .f1 .f2
+} -result {.f1 .f2}
+test busy-7.4 {tk busy current 2 busy with matching filter} -setup {
+ pack [frame .f1]
+ pack [frame .f2]
+ tk busy hold .f1
+ tk busy hold .f2
+ update
+} -body {
+ lsort [tk busy current *2*]
+} -cleanup {
+ tk busy forget .f1
+ tk busy forget .f2
+ destroy .f1 .f2
+} -result {.f2}
+test busy-7.5 {tk busy current 2 busy with non matching filter} -setup {
+ pack [frame .f1]
+ pack [frame .f2]
+ tk busy hold .f1
+ tk busy hold .f2
+ update
+} -body {
+ lsort [tk busy current *3*]
+} -cleanup {
+ tk busy forget .f1
+ tk busy forget .f2
+ destroy .f1 .f2
+} -result {}
+test busy-7.6 {tk busy current 1 busy after forget} -setup {
+ pack [frame .f]
+ tk busy hold .f
+ update
+ tk busy forget .f
+} -body {
+ tk busy current
+} -cleanup {
+ destroy .f
+} -result {}
+test busy-7.7 {tk busy current 2 busy after forget} -setup {
+ pack [frame .f1]
+ pack [frame .f2]
+ tk busy hold .f1
+ tk busy hold .f2
+ update
+ tk busy forget .f1
+} -body {
+ lsort [tk busy current]
+} -cleanup {
+ tk busy forget .f2
+ destroy .f1 .f2
+} -result {.f2}
+test busy-7.8 {tk busy current 2 busy with matching filter after forget} -setup {
+ pack [frame .f1]
+ pack [frame .f2]
+ tk busy hold .f1
+ tk busy hold .f2
+ update
+ tk busy forget .f1
+} -body {
+ lsort [tk busy current *2*]
+} -cleanup {
+ tk busy forget .f2
+ destroy .f1 .f2
+} -result {.f2}
+test busy-7.9 {tk busy current 2 busy with non matching filter after forget} -setup {
+ pack [frame .f1]
+ pack [frame .f2]
+ tk busy hold .f1
+ tk busy hold .f2
+ update
+ tk busy forget .f1
+} -body {
+ lsort [tk busy current *3*]
+} -cleanup {
+ tk busy forget .f2
+ destroy .f1 .f2
+} -result {}
+
+::tcltest::cleanupTests
+return
diff --git a/tests/button.test b/tests/button.test
index 927aac0..984fd43 100644
--- a/tests/button.test
+++ b/tests/button.test
@@ -7,427 +7,3201 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
+imageInit
proc bogusTrace args {
error "trace aborted"
}
-catch {unset value}
-catch {unset value2}
-# Create entries in the option database to be sure that geometry options
-# like border width have predictable values.
+test button-1.1 {configuration option: "activebackground" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -activebackground #012345
+ .l cget -activebackground
+} -cleanup {
+ destroy .l
+} -result {#012345}
+test button-1.2 {configuration option: "activebackground" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -activebackground non-existent
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.3 {configuration option: "activebackground" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -activebackground #012345
+ .b cget -activebackground
+} -cleanup {
+ destroy .b
+} -result {#012345}
+test button-1.4 {configuration option: "activebackground" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -activebackground non-existent
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.5 {configuration option: "activebackground" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -activebackground #012345
+ .c cget -activebackground
+} -cleanup {
+ destroy .c
+} -result {#012345}
+test button-1.6 {configuration option: "activebackground" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -activebackground non-existent
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.7 {configuration option: "activebackground" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -activebackground #012345
+ .r cget -activebackground
+} -cleanup {
+ destroy .r
+} -result {#012345}
+test button-1.8 {configuration option: "activebackground" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -activebackground non-existent
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test button-1.9 {configuration option: "activeforeground" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -activeforeground #ff0000
+ .l cget -activeforeground
+} -cleanup {
+ destroy .l
+} -result {#ff0000}
+test button-1.10 {configuration option: "activeforeground" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -activeforeground non-existent
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.11 {configuration option: "activeforeground" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -activeforeground #ff0000
+ .b cget -activeforeground
+} -cleanup {
+ destroy .b
+} -result {#ff0000}
+test button-1.12 {configuration option: "activeforeground" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -activeforeground non-existent
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.13 {configuration option: "activeforeground" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -activeforeground #ff0000
+ .c cget -activeforeground
+} -cleanup {
+ destroy .c
+} -result {#ff0000}
+test button-1.14 {configuration option: "activeforeground" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -activeforeground non-existent
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.15 {configuration option: "activeforeground" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -activeforeground #ff0000
+ .r cget -activeforeground
+} -cleanup {
+ destroy .r
+} -result {#ff0000}
+test button-1.16 {configuration option: "activeforeground" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -activeforeground non-existent
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test button-1.17 {configuration option: "anchor" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -anchor nw
+ .l cget -anchor
+} -cleanup {
+ destroy .l
+} -result {nw}
+test button-1.18 {configuration option: "anchor" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -anchor bogus
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}
+test button-1.19 {configuration option: "anchor" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -anchor nw
+ .b cget -anchor
+} -cleanup {
+ destroy .b
+} -result {nw}
+test button-1.20 {configuration option: "anchor" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -anchor bogus
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}
+test button-1.21 {configuration option: "anchor" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -anchor nw
+ .c cget -anchor
+} -cleanup {
+ destroy .c
+} -result {nw}
+test button-1.22 {configuration option: "anchor" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -anchor bogus
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}
+test button-1.23 {configuration option: "anchor" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -anchor nw
+ .r cget -anchor
+} -cleanup {
+ destroy .r
+} -result {nw}
+test button-1.24 {configuration option: "anchor" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -anchor bogus
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}
+
+test button-1.25 {configuration option: "background" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -background #ff0000
+ .l cget -background
+} -cleanup {
+ destroy .l
+} -result {#ff0000}
+test button-1.26 {configuration option: "background" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -background non-existent
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.27 {configuration option: "background" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -background #ff0000
+ .b cget -background
+} -cleanup {
+ destroy .b
+} -result {#ff0000}
+test button-1.28 {configuration option: "background" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -background non-existent
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.29 {configuration option: "background" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -background #ff0000
+ .c cget -background
+} -cleanup {
+ destroy .c
+} -result {#ff0000}
+test button-1.30 {configuration option: "background" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -background non-existent
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.31 {configuration option: "background" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -background #ff0000
+ .r cget -background
+} -cleanup {
+ destroy .r
+} -result {#ff0000}
+test button-1.32 {configuration option: "background" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -background non-existent
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test button-1.33 {configuration option: "bd" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -bd 4
+ .l cget -bd
+} -cleanup {
+ destroy .l
+} -result {4}
+test button-1.34 {configuration option: "bd" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -bd badValue
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad screen distance "badValue"}
+test button-1.35 {configuration option: "bd" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -bd 4
+ .b cget -bd
+} -cleanup {
+ destroy .b
+} -result {4}
+test button-1.36 {configuration option: "bd" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -bd badValue
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad screen distance "badValue"}
+test button-1.37 {configuration option: "bd" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -bd 4
+ .c cget -bd
+} -cleanup {
+ destroy .c
+} -result {4}
+test button-1.38 {configuration option: "bd" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -bd badValue
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad screen distance "badValue"}
+test button-1.39 {configuration option: "bd" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -bd 4
+ .r cget -bd
+} -cleanup {
+ destroy .r
+} -result {4}
+test button-1.40 {configuration option: "bd" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -bd badValue
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+test button-1.41 {configuration option: "bg" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -bg #ff0000
+ .l cget -bg
+} -cleanup {
+ destroy .l
+} -result {#ff0000}
+test button-1.42 {configuration option: "bg" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -bg non-existent
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.43 {configuration option: "bg" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -bg #ff0000
+ .b cget -bg
+} -cleanup {
+ destroy .b
+} -result {#ff0000}
+test button-1.44 {configuration option: "bg" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -bg non-existent
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.45 {configuration option: "bg" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -bg #ff0000
+ .c cget -bg
+} -cleanup {
+ destroy .c
+} -result {#ff0000}
+test button-1.46 {configuration option: "bg" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -bg non-existent
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.47 {configuration option: "bg" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -bg #ff0000
+ .r cget -bg
+} -cleanup {
+ destroy .r
+} -result {#ff0000}
+test button-1.48 {configuration option: "bg" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -bg non-existent
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test button-1.49 {configuration option: "bitmap" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -bitmap questhead
+ .l cget -bitmap
+} -cleanup {
+ destroy .l
+} -result {questhead}
+test button-1.50 {configuration option: "bitmap" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -bitmap badValue
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bitmap "badValue" not defined}
+test button-1.51 {configuration option: "bitmap" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -bitmap questhead
+ .b cget -bitmap
+} -cleanup {
+ destroy .b
+} -result {questhead}
+test button-1.52 {configuration option: "bitmap" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -bitmap badValue
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bitmap "badValue" not defined}
+test button-1.53 {configuration option: "bitmap" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -bitmap questhead
+ .c cget -bitmap
+} -cleanup {
+ destroy .c
+} -result {questhead}
+test button-1.54 {configuration option: "bitmap" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -bitmap badValue
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bitmap "badValue" not defined}
+test button-1.55 {configuration option: "bitmap" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -bitmap questhead
+ .r cget -bitmap
+} -cleanup {
+ destroy .r
+} -result {questhead}
+test button-1.56 {configuration option: "bitmap" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -bitmap badValue
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bitmap "badValue" not defined}
+
+test button-1.57 {configuration option: "borderwidth" for label} -setup {
+ label .l -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -borderwidth 1.3
+ .l cget -borderwidth
+} -cleanup {
+ destroy .l
+} -result {1.3}
+test button-1.58 {configuration option: "borderwidth" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -borderwidth badValue
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad screen distance "badValue"}
+test button-1.59 {configuration option: "borderwidth" for button} -setup {
+ button .b -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -borderwidth 1.3
+ .b cget -borderwidth
+} -cleanup {
+ destroy .b
+} -result {1.3}
+test button-1.60 {configuration option: "borderwidth" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -borderwidth badValue
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad screen distance "badValue"}
+test button-1.61 {configuration option: "borderwidth" for checkbutton} -setup {
+ checkbutton .c -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -borderwidth 1.3
+ .c cget -borderwidth
+} -cleanup {
+ destroy .c
+} -result {1.3}
+test button-1.62 {configuration option: "borderwidth" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -borderwidth badValue
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad screen distance "badValue"}
+test button-1.63 {configuration option: "borderwidth" for radiobutton} -setup {
+ radiobutton .r -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -borderwidth 1.3
+ .r cget -borderwidth
+} -cleanup {
+ destroy .r
+} -result {1.3}
+test button-1.64 {configuration option: "borderwidth" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -borderwidth badValue
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+test button-1.65 {configuration option: "command" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -command {set x}
+ .b cget -command
+} -cleanup {
+ destroy .b
+} -result {set x}
+test button-1.66 {configuration option: "command" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -command {set x}
+ .b cget -command
+} -cleanup {
+ destroy .b
+} -result {set x}
+test button-1.67 {configuration option: "command" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -command {set x}
+ .c cget -command
+} -cleanup {
+ destroy .c
+} -result {set x}
+test button-1.68 {configuration option: "command" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -command {set x}
+ .r cget -command
+} -cleanup {
+ destroy .r
+} -result {set x}
+
+test button-1.69 {configuration option: "compound" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -compound left
+ .l cget -compound
+} -cleanup {
+ destroy .l
+} -result {left}
+test button-1.70 {configuration option: "compound" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -compound bogus
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad compound "bogus": must be bottom, center, left, none, right, or top}
+test button-1.71 {configuration option: "compound" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -compound left
+ .b cget -compound
+} -cleanup {
+ destroy .b
+} -result {left}
+test button-1.72 {configuration option: "compound" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -compound bogus
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad compound "bogus": must be bottom, center, left, none, right, or top}
+test button-1.73 {configuration option: "compound" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -compound left
+ .c cget -compound
+} -cleanup {
+ destroy .c
+} -result {left}
+test button-1.74 {configuration option: "compound" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -compound bogus
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad compound "bogus": must be bottom, center, left, none, right, or top}
+test button-1.75 {configuration option: "compound" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -compound left
+ .r cget -compound
+} -cleanup {
+ destroy .r
+} -result {left}
+test button-1.76 {configuration option: "compound" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -compound bogus
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad compound "bogus": must be bottom, center, left, none, right, or top}
+
+test button-1.77 {configuration option: "cursor" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -cursor arrow
+ .l cget -cursor
+} -cleanup {
+ destroy .l
+} -result {arrow}
+test button-1.78 {configuration option: "cursor" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -cursor badValue
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad cursor spec "badValue"}
+test button-1.79 {configuration option: "cursor" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -cursor arrow
+ .b cget -cursor
+} -cleanup {
+ destroy .b
+} -result {arrow}
+test button-1.80 {configuration option: "cursor" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -cursor badValue
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad cursor spec "badValue"}
+test button-1.81 {configuration option: "cursor" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -cursor arrow
+ .c cget -cursor
+} -cleanup {
+ destroy .c
+} -result {arrow}
+test button-1.82 {configuration option: "cursor" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -cursor badValue
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad cursor spec "badValue"}
+test button-1.83 {configuration option: "cursor" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -cursor arrow
+ .r cget -cursor
+} -cleanup {
+ destroy .r
+} -result {arrow}
+test button-1.84 {configuration option: "cursor" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -cursor badValue
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad cursor spec "badValue"}
+
+test button-1.85 {configuration option: "default" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -default active
+ .b cget -default
+} -cleanup {
+ destroy .b
+} -result {active}
+test button-1.86 {configuration option: "default" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -default huh?
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad default "huh?": must be active, disabled, or normal}
+
+test button-1.87 {configuration option: "disabledforeground" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -disabledforeground #00ff00
+ .l cget -disabledforeground
+} -cleanup {
+ destroy .l
+} -result {#00ff00}
+test button-1.88 {configuration option: "disabledforeground" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -disabledforeground non-existent
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.89 {configuration option: "disabledforeground" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -disabledforeground #00ff00
+ .b cget -disabledforeground
+} -cleanup {
+ destroy .b
+} -result {#00ff00}
+test button-1.90 {configuration option: "disabledforeground" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -disabledforeground non-existent
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.91 {configuration option: "disabledforeground" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -disabledforeground #00ff00
+ .c cget -disabledforeground
+} -cleanup {
+ destroy .c
+} -result {#00ff00}
+test button-1.92 {configuration option: "disabledforeground" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -disabledforeground non-existent
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.93 {configuration option: "disabledforeground" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -disabledforeground #00ff00
+ .r cget -disabledforeground
+} -cleanup {
+ destroy .r
+} -result {#00ff00}
+test button-1.94 {configuration option: "disabledforeground" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -disabledforeground non-existent
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test button-1.95 {configuration option: "fg" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -fg #110022
+ .l cget -fg
+} -cleanup {
+ destroy .l
+} -result {#110022}
+test button-1.96 {configuration option: "fg" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -fg non-existent
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.97 {configuration option: "fg" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -fg #110022
+ .b cget -fg
+} -cleanup {
+ destroy .b
+} -result {#110022}
+test button-1.98 {configuration option: "fg" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -fg non-existent
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.99 {configuration option: "fg" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -fg #110022
+ .c cget -fg
+} -cleanup {
+ destroy .c
+} -result {#110022}
+test button-1.100 {configuration option: "fg" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -fg non-existent
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.101 {configuration option: "fg" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -fg #110022
+ .r cget -fg
+} -cleanup {
+ destroy .r
+} -result {#110022}
+test button-1.102 {configuration option: "fg" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -fg non-existent
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test button-1.103 {configuration option: "font" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2
+ pack .l
+ update
+} -body {
+ .l configure -font {Helvetica -12}
+ .l cget -font
+} -cleanup {
+ destroy .l
+} -result {Helvetica -12}
+test button-1.104 {configuration option: "activebackground" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2
+ pack .l
+ update
+} -body {
+ .l configure -font {}
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {font "" doesn't exist}
+test button-1.105 {configuration option: "font" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2
+ pack .b
+ update
+} -body {
+ .b configure -font {Helvetica -12}
+ .b cget -font
+} -cleanup {
+ destroy .b
+} -result {Helvetica -12}
+test button-1.106 {configuration option: "activebackground" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2
+ pack .b
+ update
+} -body {
+ .b configure -font {}
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {font "" doesn't exist}
+test button-1.107 {configuration option: "font" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2
+ pack .c
+ update
+} -body {
+ .c configure -font {Helvetica -12}
+ .c cget -font
+} -cleanup {
+ destroy .c
+} -result {Helvetica -12}
+test button-1.108 {configuration option: "activebackground" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2
+ pack .c
+ update
+} -body {
+ .c configure -font {}
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {font "" doesn't exist}
+test button-1.109 {configuration option: "font" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2
+ pack .r
+ update
+} -body {
+ .r configure -font {Helvetica -12}
+ .r cget -font
+} -cleanup {
+ destroy .r
+} -result {Helvetica -12}
+test button-1.110 {configuration option: "activebackground" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2
+ pack .r
+ update
+} -body {
+ .r configure -font {}
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {font "" doesn't exist}
-option add *Button.borderWidth 2
-option add *Button.highlightThickness 2
-option add *Button.font {Helvetica -12 bold}
+test button-1.111 {configuration option: "foreground" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -foreground #110022
+ .l cget -foreground
+} -cleanup {
+ destroy .l
+} -result {#110022}
+test button-1.112 {configuration option: "foreground" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -foreground non-existent
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.113 {configuration option: "foreground" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -foreground #110022
+ .b cget -foreground
+} -cleanup {
+ destroy .b
+} -result {#110022}
+test button-1.114 {configuration option: "foreground" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -foreground non-existent
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.115 {configuration option: "foreground" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -foreground #110022
+ .c cget -foreground
+} -cleanup {
+ destroy .c
+} -result {#110022}
+test button-1.116 {configuration option: "foreground" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -foreground non-existent
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.117 {configuration option: "foreground" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -foreground #110022
+ .r cget -foreground
+} -cleanup {
+ destroy .r
+} -result {#110022}
+test button-1.118 {configuration option: "foreground" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -foreground non-existent
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {unknown color name "non-existent"}
-eval image delete [image names]
-if {[testConstraint testImageType]} {
+test button-1.119 {configuration option: "height" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -height 18
+ .l cget -height
+} -cleanup {
+ destroy .l
+} -result {18}
+test button-1.120 {configuration option: "height" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -height 20.0
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {expected integer but got "20.0"}
+test button-1.121 {configuration option: "height" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -height 18
+ .b cget -height
+} -cleanup {
+ destroy .b
+} -result {18}
+test button-1.122 {configuration option: "height" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -height 20.0
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {expected integer but got "20.0"}
+test button-1.123 {configuration option: "height" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -height 18
+ .c cget -height
+} -cleanup {
+ destroy .c
+} -result {18}
+test button-1.124 {configuration option: "height" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -height 20.0
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {expected integer but got "20.0"}
+test button-1.125 {configuration option: "height" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -height 18
+ .r cget -height
+} -cleanup {
+ destroy .r
+} -result {18}
+test button-1.126 {configuration option: "height" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -height 20.0
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {expected integer but got "20.0"}
+
+test button-1.127 {configuration option: "highlightbackground" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -highlightbackground #110022
+ .l cget -highlightbackground
+} -cleanup {
+ destroy .l
+} -result {#110022}
+test button-1.128 {configuration option: "highlightbackground" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -highlightbackground non-existent
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.129 {configuration option: "highlightbackground" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -highlightbackground #110022
+ .b cget -highlightbackground
+} -cleanup {
+ destroy .b
+} -result {#110022}
+test button-1.130 {configuration option: "highlightbackground" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -highlightbackground non-existent
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.131 {configuration option: "highlightbackground" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -highlightbackground #110022
+ .c cget -highlightbackground
+} -cleanup {
+ destroy .c
+} -result {#110022}
+test button-1.132 {configuration option: "highlightbackground" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -highlightbackground non-existent
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.133 {configuration option: "highlightbackground" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -highlightbackground #110022
+ .r cget -highlightbackground
+} -cleanup {
+ destroy .r
+} -result {#110022}
+test button-1.134 {configuration option: "highlightbackground" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -highlightbackground non-existent
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test button-1.135 {configuration option: "highlightcolor" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -highlightcolor #110022
+ .l cget -highlightcolor
+} -cleanup {
+ destroy .l
+} -result {#110022}
+test button-1.136 {configuration option: "highlightcolor" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -highlightcolor non-existent
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.137 {configuration option: "highlightcolor" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -highlightcolor #110022
+ .b cget -highlightcolor
+} -cleanup {
+ destroy .b
+} -result {#110022}
+test button-1.138 {configuration option: "highlightcolor" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -highlightcolor non-existent
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.139 {configuration option: "highlightcolor" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -highlightcolor #110022
+ .c cget -highlightcolor
+} -cleanup {
+ destroy .c
+} -result {#110022}
+test button-1.140 {configuration option: "highlightcolor" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -highlightcolor non-existent
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.141 {configuration option: "highlightcolor" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -highlightcolor #110022
+ .r cget -highlightcolor
+} -cleanup {
+ destroy .r
+} -result {#110022}
+test button-1.142 {configuration option: "highlightcolor" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -highlightcolor non-existent
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test button-1.143 {configuration option: "highlightthickness" for label} -setup {
+ label .l -borderwidth 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -highlightthickness 6m
+ .l cget -highlightthickness
+} -cleanup {
+ destroy .l
+} -result {6m}
+test button-1.144 {configuration option: "highlightthickness" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -highlightthickness badValue
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad screen distance "badValue"}
+test button-1.145 {configuration option: "highlightthickness" for button} -setup {
+ button .b -borderwidth 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -highlightthickness 6m
+ .b cget -highlightthickness
+} -cleanup {
+ destroy .b
+} -result {6m}
+test button-1.146 {configuration option: "highlightthickness" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -highlightthickness badValue
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad screen distance "badValue"}
+test button-1.147 {configuration option: "highlightthickness" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -highlightthickness 6m
+ .c cget -highlightthickness
+} -cleanup {
+ destroy .c
+} -result {6m}
+test button-1.148 {configuration option: "highlightthickness" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -highlightthickness badValue
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad screen distance "badValue"}
+test button-1.149 {configuration option: "highlightthickness" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -highlightthickness 6m
+ .r cget -highlightthickness
+} -cleanup {
+ destroy .r
+} -result {6m}
+test button-1.150 {configuration option: "highlightthickness" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -highlightthickness badValue
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+test button-1.151 {configuration option: "image" for label} -constraints {
+ testImageType
+} -setup {
image create test image1
-}
-label .l -text Label
-button .b -text Button
-checkbutton .c -text Checkbutton
-radiobutton .r -text Radiobutton
-pack .l .b .c .r
-update
-set i 1
-foreach test {
- {-activebackground #012345 #012345 non-existent
- {unknown color name "non-existent"} {1 1 1 1}}
- {-activeforeground #ff0000 #ff0000 non-existent
- {unknown color name "non-existent"} {1 1 1 1}}
- {-anchor nw nw bogus
- {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}
- {1 1 1 1}}
- {-background #ff0000 #ff0000 non-existent
- {unknown color name "non-existent"} {1 1 1 1}}
- {-bd 4 4 badValue {bad screen distance "badValue"} {1 1 1 1}}
- {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}
- {1 1 1 1}}
- {-bitmap questhead questhead badValue {bitmap "badValue" not defined}
- {1 1 1 1}}
- {-borderwidth 1.3 1.3 badValue {bad screen distance "badValue"} {1 1 1 1}}
- {-command "set x" {set x} {} {} {0 1 1 1}}
- {-compound left left bogus
- {bad compound "bogus": must be bottom, center, left, none, right, or top}
- {1 1 1 1}}
- {-cursor arrow arrow badValue {bad cursor spec "badValue"} {1 1 1 1}}
- {-default active active huh?
- {bad default "huh?": must be active, disabled, or normal}
- {0 1 0 0}}
- {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"}
- {1 1 1 1}}
- {-fg #110022 #110022 bogus {unknown color name "bogus"} {1 1 1 1}}
- {-font {Helvetica 12} {Helvetica 12} {} {font "" doesn't exist} {1 1 1 1}}
- {-foreground #110022 #110022 bogus {unknown color name "bogus"} {1 1 1 1}}
- {-height 18 18 20.0 {expected integer but got "20.0"} {1 1 1 1}}
- {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}
- {1 1 1 1}}
- {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"}
- {1 1 1 1}}
- {-highlightthickness 6m 6m badValue {bad screen distance "badValue"}
- {1 1 1 1}}
- {-image image1 image1 bogus {image "bogus" doesn't exist} {1 1 1 1}}
- {-indicatoron yes 1 no_way {expected boolean value but got "no_way"}
- {0 0 1 1}}
- {-justify right right bogus
- {bad justification "bogus": must be left, right, or center}
- {1 1 1 1}}
- {-offrelief flat flat 1.5
- {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
- {0 0 1 1}}
- {-offvalue lousy lousy {} {} {0 0 1 0}}
- {-onvalue fantastic fantastic {} {} {0 0 1 0}}
- {-overrelief "" "" 1.5
- {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
- {0 1 1 1}}
- {-padx 12m 12m 420x {bad screen distance "420x"} {1 1 1 1}}
- {-pady 12m 12m 420x {bad screen distance "420x"} {1 1 1 1}}
- {-repeatdelay 100 100 foo {expected integer but got "foo"} {0 1 0 0}}
- {-repeatinterval 100 100 foo {expected integer but got "foo"} {0 1 0 0}}
- {-relief flat flat 1.5
- {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
- {1 1 1 1}}
- {-selectcolor #110022 #110022 bogus {unknown color name "bogus"} {0 0 1 1}}
- {-selectimage image1 image1 bogus {image "bogus" doesn't exist} {0 0 1 1}}
- {-state normal normal bogus
- {bad state "bogus": must be active, disabled, or normal}
- {1 1 1 1}}
- {-takefocus "any string" "any string" {} {} {1 1 1 1}}
- {-text "Sample text" {Sample text} {} {} {1 1 1 1}}
- {-textvariable i i {} {} {1 1 1 1}}
- {-tristateimage image1 image1 bogus {image "bogus" doesn't exist}
- {0 0 1 1}}
- {-tristatevalue unknowable unknowable {} {} {0 0 1 1}}
- {-underline 5 5 3p {expected integer but got "3p"} {1 1 1 1}}
- {-value anyString anyString {} {} {0 0 0 1}}
- {-width 402 402 3p {expected integer but got "3p"} {1 1 1 1}}
- {-wraplength 100 100 6x {bad screen distance "6x"} {1 1 1 1}}
-} {
- lassign $test name value okResult badValue badResult classes
- foreach w {.l .b .c .r} hasOption $classes {
- set classname [winfo class $w]
- if {$hasOption} {
- test button-1.$i "configuration option $name for $classname" \
- -constraints testImageType -body "
- $w configure $name [list $value]
- lindex \[$w configure $name] 4
- " -result $okResult
- incr i
- if {$badValue ne ""} {
- test button-1.$i "configuration option $name for $classname" \
- -constraints testImageType \
- -body [list $w configure $name $badValue] \
- -returnCodes error -result $badResult
- incr i
- }
- $w configure $name [lindex [$w configure $name] 3]
- } else {
- test button-1.$i "configuration option $name for $classname" \
- -constraints testImageType \
- -body [list $w configure $name $value] \
- -returnCodes error -result "unknown option \"$name\""
- incr i
- }
- }
-}
-test button-1.$i {configuration options} {
- # Additional check to make sure that -selectcolor may be empty in
- # checkbox widgets
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -image image1
+ .l cget -image
+} -cleanup {
+ destroy .l
+ image delete image1
+} -result {image1}
+test button-1.152 {configuration option: "image" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -image bogus
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {image "bogus" doesn't exist}
+test button-1.153 {configuration option: "image" for button} -constraints {
+ testImageType
+} -setup {
+ image create test image1
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -image image1
+ .b cget -image
+} -cleanup {
+ destroy .b
+ image delete image1
+} -result {image1}
+test button-1.154 {configuration option: "image" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -image bogus
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {image "bogus" doesn't exist}
+test button-1.155 {configuration option: "image" for checkbutton} -constraints {
+ testImageType
+} -setup {
+ image create test image1
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -image image1
+ .c cget -image
+} -cleanup {
+ destroy .c
+ image delete image1
+} -result {image1}
+test button-1.156 {configuration option: "image" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -image bogus
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {image "bogus" doesn't exist}
+test button-1.157 {configuration option: "image" for radiobutton} -constraints {
+ testImageType
+} -setup {
+ image create test image1
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -image image1
+ .r cget -image
+} -cleanup {
+ destroy .r
+ image delete image1
+} -result {image1}
+test button-1.158 {configuration option: "image" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -image bogus
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {image "bogus" doesn't exist}
+
+test button-1.159 {configuration option: "indicatoron" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -indicatoron yes
+ .c cget -indicatoron
+} -cleanup {
+ destroy .c
+} -result {1}
+test button-1.160 {configuration option: "indicatoron" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -indicatoron no_way
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {expected boolean value but got "no_way"}
+test button-1.161 {configuration option: "indicatoron" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -indicatoron yes
+ .r cget -indicatoron
+} -cleanup {
+ destroy .r
+} -result {1}
+test button-1.162 {configuration option: "indicatoron" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -indicatoron no_way
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {expected boolean value but got "no_way"}
+
+test button-1.163 {configuration option: "justify" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -justify right
+ .l cget -justify
+} -cleanup {
+ destroy .l
+} -result {right}
+test button-1.164 {configuration option: "justify" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -justify bogus
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad justification "bogus": must be left, right, or center}
+test button-1.165 {configuration option: "justify" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -justify right
+ .b cget -justify
+} -cleanup {
+ destroy .b
+} -result {right}
+test button-1.166 {configuration option: "justify" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -justify bogus
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad justification "bogus": must be left, right, or center}
+test button-1.167 {configuration option: "justify" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -justify right
+ .c cget -justify
+} -cleanup {
+ destroy .c
+} -result {right}
+test button-1.168 {configuration option: "justify" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -justify bogus
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad justification "bogus": must be left, right, or center}
+test button-1.169 {configuration option: "justify" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -justify right
+ .r cget -justify
+} -cleanup {
+ destroy .r
+} -result {right}
+test button-1.170 {configuration option: "justify" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -justify bogus
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad justification "bogus": must be left, right, or center}
+
+test button-1.171 {configuration option: "offrelief" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -offrelief flat
+ .c cget -offrelief
+} -cleanup {
+ destroy .c
+} -result {flat}
+test button-1.172 {configuration option: "offrelief" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -offrelief 1.5
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+test button-1.173 {configuration option: "offrelief" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -offrelief flat
+ .r cget -offrelief
+} -cleanup {
+ destroy .r
+} -result {flat}
+test button-1.174 {configuration option: "offrelief" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -offrelief 1.5
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+
+test button-1.175 {configuration option: "offvalue" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -offvalue lousy
+ .c cget -offvalue
+} -cleanup {
+ destroy .c
+} -result {lousy}
+
+test button-1.176 {configuration option: "onvalue" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -onvalue fantastic
+ .c cget -onvalue
+} -cleanup {
+ destroy .c
+} -result {fantastic}
+
+test button-1.177 {configuration option: "overrelief" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -overrelief ""
+ .b cget -overrelief
+} -cleanup {
+ destroy .b
+} -result {}
+test button-1.178 {configuration option: "overrelief" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -overrelief 1.5
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+test button-1.179 {configuration option: "overrelief" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -overrelief ""
+ .c cget -overrelief
+} -cleanup {
+ destroy .c
+} -result {}
+test button-1.180 {configuration option: "overrelief" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -overrelief 1.5
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+test button-1.181 {configuration option: "overrelief" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -overrelief ""
+ .r cget -overrelief
+} -cleanup {
+ destroy .r
+} -result {}
+test button-1.182 {configuration option: "overrelief" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -overrelief 1.5
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+
+test button-1.183 {configuration option: "padx" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -padx 12m
+ .l cget -padx
+} -cleanup {
+ destroy .l
+} -result {12m}
+test button-1.184 {configuration option: "padx" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -padx 420x
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad screen distance "420x"}
+test button-1.185 {configuration option: "padx" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -padx 12m
+ .b cget -padx
+} -cleanup {
+ destroy .b
+} -result {12m}
+test button-1.186 {configuration option: "padx" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -padx 420x
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad screen distance "420x"}
+test button-1.187 {configuration option: "padx" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -padx 12m
+ .c cget -padx
+} -cleanup {
+ destroy .c
+} -result {12m}
+test button-1.188 {configuration option: "padx" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -padx 420x
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad screen distance "420x"}
+test button-1.189 {configuration option: "padx" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -padx 12m
+ .r cget -padx
+} -cleanup {
+ destroy .r
+} -result {12m}
+test button-1.190 {configuration option: "padx" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -padx 420x
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad screen distance "420x"}
+
+test button-1.191 {configuration option: "pady" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -pady 12m
+ .l cget -pady
+} -cleanup {
+ destroy .l
+} -result {12m}
+test button-1.192 {configuration option: "pady" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -pady 420x
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad screen distance "420x"}
+test button-1.193 {configuration option: "pady" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -pady 12m
+ .b cget -pady
+} -cleanup {
+ destroy .b
+} -result {12m}
+test button-1.194 {configuration option: "pady" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -pady 420x
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad screen distance "420x"}
+test button-1.195 {configuration option: "pady" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -pady 12m
+ .c cget -pady
+} -cleanup {
+ destroy .c
+} -result {12m}
+test button-1.196 {configuration option: "pady" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -pady 420x
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad screen distance "420x"}
+test button-1.197 {configuration option: "pady" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -pady 12m
+ .r cget -pady
+} -cleanup {
+ destroy .r
+} -result {12m}
+test button-1.198 {configuration option: "pady" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -pady 420x
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad screen distance "420x"}
+
+test button-1.199 {configuration option: "repeatdelay" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -repeatdelay 100
+ .b cget -repeatdelay
+} -cleanup {
+ destroy .b
+} -result {100}
+test button-1.200 {configuration option: "repeatdelay" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -repeatdelay foo
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {expected integer but got "foo"}
+
+test button-1.201 {configuration option: "repeatinterval" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -repeatinterval 100
+ .b cget -repeatinterval
+} -cleanup {
+ destroy .b
+} -result {100}
+test button-1.202 {configuration option: "repeatinterval" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -repeatinterval foo
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {expected integer but got "foo"}
+
+test button-1.203 {configuration option: "relief" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -relief flat
+ .l cget -relief
+} -cleanup {
+ destroy .l
+} -result {flat}
+test button-1.204 {configuration option: "relief" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -relief 1.5
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+test button-1.205 {configuration option: "relief" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -relief flat
+ .b cget -relief
+} -cleanup {
+ destroy .b
+} -result {flat}
+test button-1.206 {configuration option: "relief" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -relief 1.5
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+test button-1.207 {configuration option: "relief" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -relief flat
+ .c cget -relief
+} -cleanup {
+ destroy .c
+} -result {flat}
+test button-1.208 {configuration option: "relief" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -relief 1.5
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+test button-1.209 {configuration option: "relief" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -relief flat
+ .r cget -relief
+} -cleanup {
+ destroy .r
+} -result {flat}
+test button-1.210 {configuration option: "relief" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -relief 1.5
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+
+test button-1.211 {configuration option: "selectcolor" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -selectcolor #110022
+ .c cget -selectcolor
+} -cleanup {
+ destroy .c
+} -result {#110022}
+test button-1.212 {configuration option: "selectcolor" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -selectcolor non-existent
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {unknown color name "non-existent"}
+test button-1.213 {configuration option: "selectcolor" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -selectcolor #110022
+ .r cget -selectcolor
+} -cleanup {
+ destroy .r
+} -result {#110022}
+test button-1.214 {configuration option: "selectcolor" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -selectcolor non-existent
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test button-1.215 {configuration option: "selectimage" for checkbutton} -constraints {
+ testImageType
+} -setup {
+ image create test image1
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -selectimage image1
+ .c cget -selectimage
+} -cleanup {
+ destroy .c
+ image delete image1
+} -result {image1}
+test button-1.216 {configuration option: "selectimage" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -selectimage bogus
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {image "bogus" doesn't exist}
+test button-1.217 {configuration option: "selectimage" for radiobutton} -constraints {
+ testImageType
+} -setup {
+ image create test image1
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -selectimage image1
+ .r cget -selectimage
+} -cleanup {
+ destroy .r
+ image delete image1
+} -result {image1}
+test button-1.218 {configuration option: "selectimage" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -selectimage bogus
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {image "bogus" doesn't exist}
+
+test button-1.219 {configuration option: "state" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -state normal
+ .l cget -state
+} -cleanup {
+ destroy .l
+} -result {normal}
+test button-1.220 {configuration option: "state" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -state bogus
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad state "bogus": must be active, disabled, or normal}
+test button-1.221 {configuration option: "state" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -state normal
+ .b cget -state
+} -cleanup {
+ destroy .b
+} -result {normal}
+test button-1.222 {configuration option: "state" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -state bogus
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad state "bogus": must be active, disabled, or normal}
+test button-1.223 {configuration option: "state" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -state normal
+ .c cget -state
+} -cleanup {
+ destroy .c
+} -result {normal}
+test button-1.224 {configuration option: "state" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -state bogus
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad state "bogus": must be active, disabled, or normal}
+test button-1.225 {configuration option: "state" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -state normal
+ .r cget -state
+} -cleanup {
+ destroy .r
+} -result {normal}
+test button-1.226 {configuration option: "state" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -state bogus
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad state "bogus": must be active, disabled, or normal}
+
+test button-1.227 {configuration option: "takefocus" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -takefocus "any string"
+ .l cget -takefocus
+} -cleanup {
+ destroy .l
+} -result {any string}
+test button-1.228 {configuration option: "takefocus" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -takefocus "any string"
+ .b cget -takefocus
+} -cleanup {
+ destroy .b
+} -result {any string}
+test button-1.229 {configuration option: "takefocus" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -takefocus "any string"
+ .c cget -takefocus
+} -cleanup {
+ destroy .c
+} -result {any string}
+test button-1.230 {configuration option: "takefocus" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -takefocus "any string"
+ .r cget -takefocus
+} -cleanup {
+ destroy .r
+} -result {any string}
+
+test button-1.231 {configuration option: "text" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -text "Sample text"
+ .l cget -text
+} -cleanup {
+ destroy .l
+} -result {Sample text}
+test button-1.232 {configuration option: "text" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -text "Sample text"
+ .b cget -text
+} -cleanup {
+ destroy .b
+} -result {Sample text}
+test button-1.233 {configuration option: "text" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -text "Sample text"
+ .c cget -text
+} -cleanup {
+ destroy .c
+} -result {Sample text}
+test button-1.234 {configuration option: "text" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -text "Sample text"
+ .r cget -text
+} -cleanup {
+ destroy .r
+} -result {Sample text}
+
+test button-1.235 {configuration option: "textvariable" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -textvariable i
+ .l cget -textvariable
+} -cleanup {
+ destroy .l
+} -result {i}
+test button-1.236 {configuration option: "textvariable" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -textvariable i
+ .b cget -textvariable
+} -cleanup {
+ destroy .b
+} -result {i}
+test button-1.237 {configuration option: "textvariable" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -textvariable i
+ .c cget -textvariable
+} -cleanup {
+ destroy .c
+} -result {i}
+test button-1.238 {configuration option: "textvariable" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -textvariable i
+ .r cget -textvariable
+} -cleanup {
+ destroy .r
+} -result {i}
+
+test button-1.239 {configuration option: "tristateimage" for checkbutton} -constraints {
+ testImageType
+} -setup {
+ image create test image1
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -tristateimage image1
+ .c cget -tristateimage
+} -cleanup {
+ destroy .c
+ image delete image1
+} -result {image1}
+test button-1.240 {configuration option: "tristateimage" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -tristateimage bogus
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {image "bogus" doesn't exist}
+test button-1.241 {configuration option: "tristateimage" for radiobutton} -constraints {
+ testImageType
+} -setup {
+ image create test image1
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -tristateimage image1
+ .r cget -tristateimage
+} -cleanup {
+ destroy .r
+ image delete image1
+} -result {image1}
+test button-1.242 {configuration option: "tristateimage" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -tristateimage bogus
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {image "bogus" doesn't exist}
+
+test button-1.243 {configuration option: "underline" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -underline 5
+ .l cget -underline
+} -cleanup {
+ destroy .l
+} -result {5}
+test button-1.244 {configuration option: "underline" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -underline 3p
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {expected integer but got "3p"}
+test button-1.245 {configuration option: "underline" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -underline 5
+ .b cget -underline
+} -cleanup {
+ destroy .b
+} -result {5}
+test button-1.246 {configuration option: "underline" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -underline 3p
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {expected integer but got "3p"}
+test button-1.247 {configuration option: "underline" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -underline 5
+ .c cget -underline
+} -cleanup {
+ destroy .c
+} -result {5}
+test button-1.248 {configuration option: "underline" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -underline 3p
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {expected integer but got "3p"}
+test button-1.249 {configuration option: "underline" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -underline 5
+ .r cget -underline
+} -cleanup {
+ destroy .r
+} -result {5}
+test button-1.250 {configuration option: "underline" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -underline 3p
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {expected integer but got "3p"}
+
+test button-1.251 {configuration option: "tristatevalue" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -tristatevalue unknowable
+ .c cget -tristatevalue
+} -cleanup {
+ destroy .c
+} -result {unknowable}
+test button-1.252 {configuration option: "tristatevalue" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -tristatevalue unknowable
+ .r cget -tristatevalue
+} -cleanup {
+ destroy .r
+} -result {unknowable}
+
+test button-1.253 {configuration option: "value" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -value anyString
+ .r cget -value
+} -cleanup {
+ destroy .r
+} -result {anyString}
+
+test button-1.254 {configuration option: "width" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -width 402
+ .l cget -width
+} -cleanup {
+ destroy .l
+} -result {402}
+test button-1.255 {configuration option: "width" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -width 3p
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {expected integer but got "3p"}
+test button-1.256 {configuration option: "width" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -width 402
+ .b cget -width
+} -cleanup {
+ destroy .b
+} -result {402}
+test button-1.257 {configuration option: "width" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -width 3p
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {expected integer but got "3p"}
+test button-1.258 {configuration option: "width" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -width 402
+ .c cget -width
+} -cleanup {
+ destroy .c
+} -result {402}
+test button-1.259 {configuration option: "width" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -width 3p
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {expected integer but got "3p"}
+test button-1.260 {configuration option: "width" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -width 402
+ .r cget -width
+} -cleanup {
+ destroy .r
+} -result {402}
+test button-1.261 {configuration option: "width" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -width 3p
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {expected integer but got "3p"}
+
+test button-1.262 {configuration option: "wraplength" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -wraplength 100
+ .l cget -wraplength
+} -cleanup {
+ destroy .l
+} -result {100}
+test button-1.263 {configuration option: "wraplength" for label} -setup {
+ label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .l
+ update
+} -body {
+ .l configure -wraplength 6x
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad screen distance "6x"}
+test button-1.264 {configuration option: "wraplength" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -wraplength 100
+ .b cget -wraplength
+} -cleanup {
+ destroy .b
+} -result {100}
+test button-1.265 {configuration option: "wraplength" for button} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .b
+ update
+} -body {
+ .b configure -wraplength 6x
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad screen distance "6x"}
+test button-1.266 {configuration option: "wraplength" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -wraplength 100
+ .c cget -wraplength
+} -cleanup {
+ destroy .c
+} -result {100}
+test button-1.267 {configuration option: "wraplength" for checkbutton} -setup {
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .c
+ update
+} -body {
+ .c configure -wraplength 6x
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {bad screen distance "6x"}
+test button-1.268 {configuration option: "wraplength" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -wraplength 100
+ .r cget -wraplength
+} -cleanup {
+ destroy .r
+} -result {100}
+test button-1.269 {configuration option: "wraplength" for radiobutton} -setup {
+ radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .r
+ update
+} -body {
+ .r configure -wraplength 6x
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad screen distance "6x"}
+
+test button-1.270 {configuration options} -body {
+# Additional check to make sure that -selectcolor may be empty in
+# checkbox widgets
+ checkbutton .c
.c configure -selectcolor {}
-} {}
-
-test button-3.1 {ButtonCreate - not enough cd ../unix
-} {
- list [catch {button} msg] $msg
-} {1 {wrong # args: should be "button pathName ?options?"}}
-test button-3.2 {ButtonCreate procedure - setting label class} {
- catch {destroy .x}
+} -cleanup {
+ destroy .c
+} -result {}
+
+# ex-tests 3.*
+test button-2.1 {ButtonCreate - not enough arguments} -body {
+ button
+} -returnCodes {error} -result {wrong # args: should be "button pathName ?-option value ...?"}
+
+test button-2.2 {ButtonCreate procedure - setting label class} -body {
label .x
winfo class .x
-} {Label}
-test button-3.3 {ButtonCreate - setting button class} {
- catch {destroy .x}
+} -cleanup {
+ destroy .x
+} -result {Label}
+test button-2.3 {ButtonCreate - setting button class} -body {
button .x
winfo class .x
-} {Button}
-test button-3.4 {ButtonCreate - setting checkbutton class} {
- catch {destroy .x}
+} -cleanup {
+ destroy .x
+} -result {Button}
+test button-2.4 {ButtonCreate - setting checkbutton class} -body {
checkbutton .x
winfo class .x
-} {Checkbutton}
-test button-3.5 {ButtonCreate - setting radiobutton class} {
- catch {destroy .x}
+} -cleanup {
+ destroy .x
+} -result {Checkbutton}
+test button-2.5 {ButtonCreate - setting radiobutton class} -body {
radiobutton .x
winfo class .x
-} {Radiobutton}
-rename button gorp
-test button-3.6 {ButtonCreate - setting class} {
- catch {destroy .x}
+} -cleanup {
+ destroy .x
+} -result {Radiobutton}
+test button-2.6 {ButtonCreate - setting class} -body {
+ rename button gorp
gorp .x
winfo class .x
-} {Button}
-rename gorp button
-test button-3.7 {ButtonCreate - bad window name} {
- list [catch {button foo} msg] $msg
-} {1 {bad window path name "foo"}}
-test button-3.8 {ButtonCreate procedure - error in default option value} {
- catch {destroy .funny}
+} -cleanup {
+ destroy .x
+ rename gorp button
+} -result {Button}
+
+test button-2.7 {ButtonCreate - bad window name} -body {
+ button foo
+} -cleanup {
+ destroy foo
+} -returnCodes {error} -result {bad window path name "foo"}
+######### test ex 3.8
+test button-2.8 {ButtonCreate procedure - error in default option value} -body {
option add *funny.background bogus
- list [catch {button .funny} msg] $msg $errorInfo
-} {1 {unknown color name "bogus"} {unknown color name "bogus"
+ button .funny
+} -cleanup {
+ option clear
+ destroy .funny
+} -returnCodes {error} -result {unknown color name "bogus"}
+test button-2.9 {ButtonCreate procedure - error in default option value} -body {
+ option add *funny.background bogus
+ catch {button .funny}
+ return $errorInfo
+} -cleanup {
+ option clear
+ destroy .funny
+} -result {unknown color name "bogus"
(database entry for "-background" in widget ".funny")
invoked from within
-"button .funny"}}
-test button-3.9 {ButtonCreate procedure - option error} {
- catch {destroy .x}
- list [catch {button .x -gorp foo} msg] $msg [winfo exists .x]
-} {1 {unknown option "-gorp"} 0}
-test button-3.10 {ButtonCreate procedure - return value} {
- catch {destroy .abcd}
+"button .funny"}
+
+test button-2.10 {ButtonCreate procedure - option error} -body {
+ button .x -gorp foo
+} -cleanup {
+ destroy .x
+} -returnCodes {error} -result {unknown option "-gorp"}
+test button-2.11 {ButtonCreate procedure - option error} -body {
+ catch {button .x -gorp foo}
+ winfo exists .x
+} -cleanup {
+ destroy .x
+} -result 0
+######### ex 3.10
+test button-2.12 {ButtonCreate procedure - return value} -body {
set x [button .abcd]
- destroy .abc
- set x
-} {.abcd}
-
-test button-4.1 {ButtonWidgetCmd - too few arguments} {
- list [catch {.b} msg] $msg
-} {1 {wrong # args: should be ".b option ?arg arg ...?"}}
-test button-4.2 {ButtonWidgetCmd - bad option name} {
- list [catch {.b c} msg] $msg
-} {1 {ambiguous option "c": must be cget, configure, flash, or invoke}}
-test button-4.3 {ButtonWidgetCmd - bad option name} {
- list [catch {.b bogus} msg] $msg
-} {1 {bad option "bogus": must be cget, configure, flash, or invoke}}
-test button-4.4 {ButtonWidgetCmd procedure, "cget" option} {
- list [catch {.b cget a b} msg] $msg
-} {1 {wrong # args: should be ".b cget option"}}
-test button-4.5 {ButtonWidgetCmd procedure, "cget" option} {
- list [catch {.b cget -gorp} msg] $msg
-} {1 {unknown option "-gorp"}}
-test button-4.6 {ButtonWidgetCmd procedure, "cget" option} {
- .b configure -highlightthickness 3
- .b cget -highlightthickness
-} {3}
-test button-4.7 {ButtonWidgetCmd procedure, "cget" option} {
- catch {.l cget -disabledforeground}
-} {0}
-test button-4.8 {ButtonWidgetCmd procedure, "cget" option} {
- catch {.b cget -disabledforeground}
-} {0}
-test button-4.9 {ButtonWidgetCmd procedure, "cget" option} {
- list [catch {.b cget -variable} msg] $msg
-} {1 {unknown option "-variable"}}
-test button-4.10 {ButtonWidgetCmd procedure, "cget" option} {
- catch {.c cget -variable}
-} {0}
-test button-4.11 {ButtonWidgetCmd procedure, "cget" option} {
- list [catch {.c cget -value} msg] $msg
-} {1 {unknown option "-value"}}
-test button-4.12 {ButtonWidgetCmd procedure, "cget" option} {
- catch {.r cget -value}
-} {0}
-test button-4.13 {ButtonWidgetCmd procedure, "cget" option} {
- list [catch {.r cget -onvalue} msg] $msg
-} {1 {unknown option "-onvalue"}}
-test button-4.14 {ButtonWidgetCmd procedure, "configure" option} {
+ return $x
+} -cleanup {
+ destroy .abcd
+} -result {.abcd}
+
+######### ex 4.*
+test button-3.1 {ButtonWidgetCmd - too few arguments} -body {
+ button .b
+ .b
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {wrong # args: should be ".b option ?arg ...?"}
+test button-3.2 {ButtonWidgetCmd - bad option name} -body {
+ button .b
+ .b c
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {ambiguous option "c": must be cget, configure, flash, or invoke}
+test button-3.3 {ButtonWidgetCmd - bad option name} -body {
+ button .b
+ .b bogus
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad option "bogus": must be cget, configure, flash, or invoke}
+test button-3.4 {ButtonWidgetCmd procedure, "cget" option} -body {
+ button .b
+ .b cget a b
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {wrong # args: should be ".b cget option"}
+test button-3.5 {ButtonWidgetCmd procedure, "cget" option} -body {
+ button .b
+ .b cget -gorp
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {unknown option "-gorp"}
+
+#ex 4.7
+test button-3.6 {ButtonWidgetCmd procedure, "cget" option} -body {
+ label .l
+ .l cget -disabledforeground
+} -cleanup {
+ destroy .l
+} -returnCodes {ok} -match {glob} -result {*}
+test button-3.7 {ButtonWidgetCmd procedure, "cget" option} -body {
+ button .b
+ .b cget -disabledforeground
+} -cleanup {
+ destroy .b
+} -returnCodes {ok} -match {glob} -result {*}
+test button-3.8 {ButtonWidgetCmd procedure, "cget" option} -body {
+ button .b
+ .b cget -variable
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {unknown option "-variable"}
+
+test button-3.9 {ButtonWidgetCmd procedure, "cget" option} -body {
+ checkbutton .c
+ .c cget -variable
+} -cleanup {
+ destroy .c
+} -returnCodes {ok} -match {glob} -result {*}
+test button-3.10 {ButtonWidgetCmd procedure, "cget" option} -body {
+ checkbutton .c
+ .c cget -value
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {unknown option "-value"}
+
+test button-3.11 {ButtonWidgetCmd procedure, "cget" option} -body {
+ radiobutton .r
+ .r cget -value
+} -cleanup {
+ destroy .r
+} -returnCodes {ok} -match {glob} -result {*}
+test button-3.12 {ButtonWidgetCmd procedure, "cget" option} -body {
+ radiobutton .r
+ .r cget -onvalue
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {unknown option "-onvalue"}
+
+# ex 4.6
+test button-3.13 {ButtonWidgetCmd procedure, "configure" option} -body {
+ button .b -highlightthickness 3
+ lindex [.b configure -highlightthickness] 4
+} -cleanup {
+ destroy .b
+} -result {3}
+test button-3.14 {ButtonWidgetCmd procedure, "configure" option} -body {
+ checkbutton .c
llength [.c configure]
-} {41}
-test button-4.15 {ButtonWidgetCmd procedure, "configure" option} {
- list [catch {.b configure -gorp} msg] $msg
-} {1 {unknown option "-gorp"}}
-test button-4.16 {ButtonWidgetCmd procedure, "configure" option} {
- list [catch {.b co -bg #ffffff -fg} msg] $msg
-} {1 {value for "-fg" missing}}
-test button-4.17 {ButtonWidgetCmd procedure, "configure" option} {
+} -cleanup {
+ destroy .c
+} -result {41}
+test button-3.15 {ButtonWidgetCmd procedure, "configure" option} -body {
+ button .b
+ .b configure -gorp
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {unknown option "-gorp"}
+test button-3.16 {ButtonWidgetCmd procedure, "configure" option} -setup {
+ button .b
+} -body {
+ .b co -bg #ffffff -fg
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {value for "-fg" missing}
+test button-3.17 {ButtonWidgetCmd procedure, "configure" option} -setup {
+ button .b
+} -body {
.b configure -fg #123456
.b configure -bg #654321
lindex [.b configure -fg] 4
-} {#123456}
-.c configure -variable value -onvalue 1 -offvalue 0
-.r configure -variable value2 -value red
-test button-4.18 {ButtonWidgetCmd procedure, "deselect" option} {
- list [catch {.c deselect foo} msg] $msg
-} {1 {wrong # args: should be ".c deselect"}}
-test button-4.19 {ButtonWidgetCmd procedure, "deselect" option} {
- list [catch {.l deselect} msg] $msg
-} {1 {bad option "deselect": must be cget or configure}}
-test button-4.20 {ButtonWidgetCmd procedure, "deselect" option} {
- list [catch {.b deselect} msg] $msg
-} {1 {bad option "deselect": must be cget, configure, flash, or invoke}}
-test button-4.21 {ButtonWidgetCmd procedure, "deselect" option} {
- set value 1
+} -cleanup {
+ destroy .b
+} -result {#123456}
+test button-3.18 {ButtonWidgetCmd procedure, "deselect" option} -body {
+ checkbutton .c
+ .c deselect foo
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {wrong # args: should be ".c deselect"}
+test button-3.19 {ButtonWidgetCmd procedure, "deselect" option} -body {
+ label .l
+ .l deselect
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad option "deselect": must be cget or configure}
+test button-3.20 {ButtonWidgetCmd procedure, "deselect" option} -body {
+ button .b
+ .b deselect
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad option "deselect": must be cget, configure, flash, or invoke}
+
+test button-3.21 {ButtonWidgetCmd procedure, "deselect" option} -body {
+ checkbutton .c -variable checkvar -onvalue 1 -offvalue 0
+ set checkvar 1
.c d
- set value
-} {0}
-test button-4.22 {ButtonWidgetCmd procedure, "deselect" option} {
- set value2 green
+ return $checkvar
+} -cleanup {
+ destroy .c
+} -result {0}
+test button-3.22 {ButtonWidgetCmd procedure, "deselect" option} -body {
+ radiobutton .r -variable radiovar -value red
+ set radiovar green
.r deselect
- set value2
-} {green}
-test button-4.23 {ButtonWidgetCmd procedure, "deselect" option} {
- set value2 red
+ return $radiovar
+} -cleanup {
+ destroy .r
+} -result {green}
+test button-3.23 {ButtonWidgetCmd procedure, "deselect" option} -body {
+ radiobutton .r -variable radiovar -value red
+ set radiovar red
.r deselect
- set value2
-} {}
-test button-4.24 {ButtonWidgetCmd procedure, "deselect" option} -body {
- set value 1
- trace variable value w bogusTrace
- set result [list [catch {.c deselect} msg] $msg $errorInfo $value]
- trace vdelete value w bogusTrace
- set result
-} -match glob -result {1 {can't set "value": trace aborted} {*trace aborted
+ return $radiovar
+} -cleanup {
+ destroy .r
+} -result {}
+
+test button-3.24 {ButtonWidgetCmd procedure, "deselect" option} -body {
+ checkbutton .c -variable checkvar -onvalue 1 -offvalue 0
+ set checkvar 1
+ trace variable checkvar w bogusTrace
+ .c deselect
+} -cleanup {
+ destroy .c
+ trace vdelete checkvar w bogusTrace
+} -returnCodes {error} -result {can't set "checkvar": trace aborted}
+test button-3.25 {ButtonWidgetCmd procedure, "deselect" option} -body {
+ checkbutton .c -variable checkvar -onvalue 1 -offvalue 0
+ set checkvar 1
+ trace variable checkvar w bogusTrace
+ catch {.c deselect}
+ list $errorInfo $checkvar
+} -cleanup {
+ trace vdelete checkvar w bogusTrace
+ destroy .c
+} -match {glob} -result {{*trace aborted
while executing
*
".c deselect"} 0}
-test button-4.25 {ButtonWidgetCmd procedure, "deselect" option} -body {
- set value2 red
- trace variable value2 w bogusTrace
- set result [list [catch {.r deselect} msg] $msg $errorInfo $value2]
- trace vdelete value2 w bogusTrace
- set result
-} -match glob -result {1 {can't set "value2": trace aborted} {*trace aborted
+test button-3.26 {ButtonWidgetCmd procedure, "deselect" option} -body {
+ radiobutton .r -variable radiovar -value red
+ set radiovar red
+ trace variable radiovar w bogusTrace
+ .r deselect
+} -cleanup {
+ destroy .r
+ trace vdelete radiovar w bogusTrace
+} -match {glob} -returnCodes {error} -result {can't set "radiovar": trace aborted}
+test button-3.27 {ButtonWidgetCmd procedure, "deselect" option} -body {
+ radiobutton .r -variable radiovar -value red
+ set radiovar red
+ trace variable radiovar w bogusTrace
+ catch {.r deselect}
+ list $errorInfo $radiovar
+} -cleanup {
+ destroy .r
+ trace vdelete radiovar w bogusTrace
+} -match glob -result {{*trace aborted
while executing
*
".r deselect"} {}}
-test button-4.26 {ButtonWidgetCmd procedure, "flash" option} {
- list [catch {.b flash foo} msg] $msg
-} {1 {wrong # args: should be ".b flash"}}
-test button-4.27 {ButtonWidgetCmd procedure, "flash" option} {
- list [catch {.l flash} msg] $msg
-} {1 {bad option "flash": must be cget or configure}}
-test button-4.28 {ButtonWidgetCmd procedure, "flash" option} {
- list [catch {.b flash} msg] $msg
-} {0 {}}
-test button-4.29 {ButtonWidgetCmd procedure, "flash" option} {
- list [catch {.c flash} msg] $msg
-} {0 {}}
-test button-4.30 {ButtonWidgetCmd procedure, "flash" option} {
- list [catch {.r f} msg] $msg
-} {0 {}}
-test button-4.31 {ButtonWidgetCmd procedure, "invoke" option} {
- list [catch {.b invoke foo} msg] $msg
-} {1 {wrong # args: should be ".b invoke"}}
-test button-4.32 {ButtonWidgetCmd procedure, "invoke" option} {
- list [catch {.l invoke} msg] $msg
-} {1 {bad option "invoke": must be cget or configure}}
-test button-4.33 {ButtonWidgetCmd procedure, "invoke" option} {
+
+test button-3.28 {ButtonWidgetCmd procedure, "flash" option} -body {
+ button .b
+ .b flash foo
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {wrong # args: should be ".b flash"}
+test button-3.29 {ButtonWidgetCmd procedure, "flash" option} -body {
+ label .l
+ .l flash
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad option "flash": must be cget or configure}
+test button-3.30 {ButtonWidgetCmd procedure, "flash" option} -body {
+ button .b
+ catch {.b flash}
+} -cleanup {
+ destroy .b
+} -returnCodes {ok} -match {glob} -result {*}
+test button-3.31 {ButtonWidgetCmd procedure, "flash" option} -body {
+ checkbutton .c
+ catch {.c flash}
+} -cleanup {
+ destroy .c
+} -returnCodes {ok} -match {glob} -result {*}
+test button-3.32 {ButtonWidgetCmd procedure, "flash" option} -body {
+ radiobutton .r
+ catch {.r f}
+} -cleanup {
+ destroy .r
+} -returnCodes {ok} -match {glob} -result {*}
+
+test button-3.33 {ButtonWidgetCmd procedure, "invoke" option} -body {
+ label .l
+ .l invoke
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad option "invoke": must be cget or configure}
+test button-3.34 {ButtonWidgetCmd procedure, "invoke" option} -body {
+ button .b
+ .b invoke foo
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {wrong # args: should be ".b invoke"}
+test button-3.35 {ButtonWidgetCmd procedure, "invoke" option} -body {
+ button .b
.b configure -command {set x invoked}
set x "not invoked"
.b invoke
- set x
-} {invoked}
-test button-4.34 {ButtonWidgetCmd procedure, "invoke" option} {
+ return $x
+} -cleanup {
+ destroy .b
+} -result {invoked}
+test button-3.36 {ButtonWidgetCmd procedure, "invoke" option} -body {
+ button .b
.b configure -command {set x invoked} -state disabled
set x "not invoked"
.b invoke
- set x
-} {not invoked}
-test button-4.35 {ButtonWidgetCmd procedure, "invoke" option} {
- set value bogus
- .c configure -command {set x invoked} -variable value -onvalue 1 \
- -offvalue 0
+ return $x
+} -cleanup {
+ destroy .b
+} -result {not invoked}
+test button-3.37 {ButtonWidgetCmd procedure, "invoke" option} -body {
+ checkbutton .c -variable checkvar -onvalue 1 -offvalue 0 \
+ -command {set x invoked}
+ set checkvar bogus
set x "not invoked"
.c invoke
- list $x $value
-} {invoked 1}
-test button-4.36 {ButtonWidgetCmd procedure, "invoke" option} {
- set value2 green
- .r configure -command {set x invoked} -variable value2 -value red
+ list $x $checkvar
+} -cleanup {
+ destroy .c
+} -result {invoked 1}
+test button-3.38 {ButtonWidgetCmd procedure, "invoke" option} -body {
+ radiobutton .r -command {set x invoked} -variable radiovar -value red
+ set radiovar green
set x "not invoked"
.r i
- list $x $value2
-} {invoked red}
-test button-4.37 {ButtonWidgetCmd procedure, "select" option} {
- list [catch {.l select} msg] $msg
-} {1 {bad option "select": must be cget or configure}}
-test button-4.38 {ButtonWidgetCmd procedure, "select" option} {
- list [catch {.b select} msg] $msg
-} {1 {bad option "select": must be cget, configure, flash, or invoke}}
-test button-4.39 {ButtonWidgetCmd procedure, "select" option} {
- list [catch {.c select foo} msg] $msg
-} {1 {wrong # args: should be ".c select"}}
-test button-4.40 {ButtonWidgetCmd procedure, "select" option} {
- set value bogus
- .c configure -command {} -variable value -onvalue lovely -offvalue 0
+ list $x $radiovar
+} -cleanup {
+ destroy .r
+} -result {invoked red}
+
+test button-3.39 {ButtonWidgetCmd procedure, "select" option} -body {
+ label .l
+ .l select
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad option "select": must be cget or configure}
+test button-3.40 {ButtonWidgetCmd procedure, "select" option} -body {
+ button .b
+ .b select
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad option "select": must be cget, configure, flash, or invoke}
+test button-3.41 {ButtonWidgetCmd procedure, "select" option} -body {
+ checkbutton .c
+ .c select foo
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {wrong # args: should be ".c select"}
+test button-3.42 {ButtonWidgetCmd procedure, "select" option} -body {
+ checkbutton .c -variable checkvar -onvalue lovely -offvalue 0
+ set checkvar bogus
.c s
- set value
-} {lovely}
-test button-4.41 {ButtonWidgetCmd procedure, "select" option} {
- set value2 green
- .r configure -command {} -variable value2 -value red
+ return $checkvar
+} -cleanup {
+ destroy .c
+} -result {lovely}
+test button-3.43 {ButtonWidgetCmd procedure, "select" option} -body {
+ radiobutton .r -variable radiovar -value red
+ set radiovar green
+ .r select
+ return $radiovar
+} -cleanup {
+ destroy .r
+} -result {red}
+test button-3.44 {ButtonWidgetCmd procedure, "select" option} -body {
+ radiobutton .r -variable radiovar -value red
+ set radiovar yellow
+ trace variable radiovar w bogusTrace
.r select
- set value2
-} {red}
-test button-4.42 {ButtonWidgetCmd procedure, "select" option} -body {
- set value2 yellow
- trace variable value2 w bogusTrace
- set result [list [catch {.r select} msg] $msg $errorInfo $value2]
- trace vdelete value2 w bogusTrace
- set result
-} -match glob -result {1 {can't set "value2": trace aborted} {*trace aborted
+} -cleanup {
+ destroy .r
+ trace vdelete radiovar w bogusTrace
+} -returnCodes {error} -result {can't set "radiovar": trace aborted}
+test button-3.45 {ButtonWidgetCmd procedure, "select" option} -body {
+ radiobutton .r -variable radiovar -value red
+ set radiovar yellow
+ trace variable radiovar w bogusTrace
+ catch {.r select}
+ list $errorInfo $radiovar
+} -cleanup {
+ destroy .r
+ trace vdelete radiovar w bogusTrace
+} -match {glob} -result {{*trace aborted
while executing
*
".r select"} red}
-test button-4.43 {ButtonWidgetCmd procedure, "toggle" option} {
- list [catch {.l toggle} msg] $msg
-} {1 {bad option "toggle": must be cget or configure}}
-test button-4.44 {ButtonWidgetCmd procedure, "toggle" option} {
- list [catch {.b toggle} msg] $msg
-} {1 {bad option "toggle": must be cget, configure, flash, or invoke}}
-test button-4.45 {ButtonWidgetCmd procedure, "toggle" option} {
- list [catch {.r toggle} msg] $msg
-} {1 {bad option "toggle": must be cget, configure, deselect, flash, invoke, or select}}
-test button-4.46 {ButtonWidgetCmd procedure, "toggle" option} {
- list [catch {.c toggle foo} msg] $msg
-} {1 {wrong # args: should be ".c toggle"}}
-test button-4.47 {ButtonWidgetCmd procedure, "toggle" option} {
- set value bogus
- .c configure -command {} -variable value -onvalue sunshine -offvalue rain
+
+# ex 4.43
+test button-3.46 {ButtonWidgetCmd procedure, "toggle" option} -body {
+ label .l
+ .l toggle
+} -cleanup {
+ destroy .l
+} -returnCodes {error} -result {bad option "toggle": must be cget or configure}
+test button-3.47 {ButtonWidgetCmd procedure, "toggle" option} -body {
+ button .b
+ .b toggle
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad option "toggle": must be cget, configure, flash, or invoke}
+test button-3.48 {ButtonWidgetCmd procedure, "toggle" option} -body {
+ radiobutton .r
+ .r toggle
+} -cleanup {
+ destroy .r
+} -returnCodes {error} -result {bad option "toggle": must be cget, configure, deselect, flash, invoke, or select}
+test button-3.49 {ButtonWidgetCmd procedure, "toggle" option} -body {
+ checkbutton .c
+ .c toggle foo
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {wrong # args: should be ".c toggle"}
+test button-3.50 {ButtonWidgetCmd procedure, "toggle" option} -body {
+ set checkvar bogus
+ checkbutton .c -variable checkvar -onvalue sunshine -offvalue rain
.c toggle
- set result $value
+ set result $checkvar
.c toggle
- lappend result $value
+ lappend result $checkvar
.c toggle
- lappend result $value
-} {sunshine rain sunshine}
-test button-4.48 {ButtonWidgetCmd procedure, "toggle" option} -body {
- .c configure -onvalue xyz -offvalue abc
- set value xyz
- trace variable value w bogusTrace
- set result [list [catch {.c toggle} msg] $msg $errorInfo $value]
- trace vdelete value w bogusTrace
- set result
-} -match glob -result {1 {can't set "value": trace aborted} {*trace aborted
+ lappend result $checkvar
+ return $result
+} -cleanup {
+ destroy .c
+} -result {sunshine rain sunshine}
+test button-3.51 {ButtonWidgetCmd procedure, "toggle" option} -body {
+ checkbutton .c -variable checkvar -onvalue xyz -offvalue abc
+ set checkvar xyz
+ trace variable checkvar w bogusTrace
+ .c toggle
+} -cleanup {
+ destroy .c
+ trace vdelete checkvar w bogusTrace
+} -returnCodes {error} -result {can't set "checkvar": trace aborted}
+test button-3.52 {ButtonWidgetCmd procedure, "toggle" option} -body {
+ checkbutton .c -variable checkvar -onvalue xyz -offvalue abc
+ set checkvar xyz
+ trace variable checkvar w bogusTrace
+ catch {.c toggle}
+ list $errorInfo $checkvar
+} -cleanup {
+ trace vdelete checkvar w bogusTrace
+ destroy .c
+} -match {glob} -result {{*trace aborted
while executing
*
".c toggle"} abc}
-test button-4.49 {ButtonWidgetCmd procedure, "toggle" option} -body {
- .c configure -onvalue xyz -offvalue abc
- set value abc
- trace variable value w bogusTrace
- set result [list [catch {.c toggle} msg] $msg $errorInfo $value]
- trace vdelete value w bogusTrace
- set result
-} -match glob -result {1 {can't set "value": trace aborted} {*trace aborted
+test button-3.53 {ButtonWidgetCmd procedure, "toggle" option} -body {
+ checkbutton .c -variable checkvar -onvalue xyz -offvalue abc
+ set checkvar abc
+ trace variable checkvar w bogusTrace
+ .c toggle
+} -cleanup {
+ trace vdelete checkvar w bogusTrace
+ destroy .c
+} -returnCodes {error} -result {can't set "checkvar": trace aborted}
+test button-3.54 {ButtonWidgetCmd procedure, "toggle" option} -body {
+ checkbutton .c -variable checkvar -onvalue xyz -offvalue abc
+ set checkvar abc
+ trace variable checkvar w bogusTrace
+ catch {.c toggle}
+ list $errorInfo $checkvar
+} -cleanup {
+ trace vdelete checkvar w bogusTrace
+ destroy .c
+} -match {glob} -result {{*trace aborted
while executing
*
".c toggle"} xyz}
-test button-4.50 {ButtonWidgetCmd procedure, "toggle" option} {
- catch {unset value}; set value(1) 1;
- set result [list [catch {.c toggle} msg] $msg $errorInfo]
- unset value;
- set result
-} {1 {can't set "value": variable is array} {can't set "value": variable is array
+test button-3.55 {ButtonWidgetCmd procedure, "toggle" option} -setup {
+ unset -nocomplain checkvar
+} -body {
+ checkbutton .c -variable checkvar -onvalue xyz -offvalue abc
+ unset checkvar
+ set checkvar(1) 1
+ .c toggle
+} -cleanup {
+ destroy .c
+} -returnCodes {error} -result {can't set "checkvar": variable is array}
+test button-3.56 {ButtonWidgetCmd procedure, "toggle" option} -setup {
+ unset -nocomplain checkvar
+} -body {
+ checkbutton .c -variable checkvar -onvalue xyz -offvalue abc
+ unset checkvar
+ set checkvar(1) 1
+ catch {.c toggle}
+ return $errorInfo
+} -cleanup {
+ destroy .c
+} -match {glob} -result {can't set "checkvar": variable is array
while executing
-".c toggle"}}
+".c toggle"}
-test button-5.1 {DestroyButton procedure} testImageType {
+test button-4.1 {DestroyButton procedure} -constraints {
+ testImageType
+} -setup {
image create test image1
+ unset -nocomplain x
+} -body {
button .b1 -image image1
button .b2 -fg #ff0000 -text "Button 2"
button .b3 -state active -text "Button 3"
@@ -435,402 +3209,709 @@ test button-5.1 {DestroyButton procedure} testImageType {
checkbutton .b5 -variable x -text "Checkbutton 5"
set x 1
pack .b1 .b2 .b3 .b4 .b5
- update
- deleteWindows
-} {}
-
-test button-6.1 {ConfigureButton - textvariable trace} {
- catch {destroy .b1}
- button .b1 -bd 4 -bg green
- catch {.b1 configure -bd 7 -bg green -fg bogus}
- list [catch {.b1 configure -bd 7 -bg red -fg bogus} msg] \
- $msg [.b1 cget -bd] [.b1 cget -bg]
-} {1 {unknown color name "bogus"} 4 green}
-test button-6.2 {ConfigureButton - textvariable trace} {
- catch {destroy .b1}
+ update
+ deleteWindows
+} -cleanup {
+ destroy .b1 .b2 .b3 .b4 .b5
+ image delete image1
+} -result {}
+
+test button-5.1 {ConfigureButton - textvariable trace} -body {
+ button .b -bd 4 -bg green
+ .b configure -bd 7 -bg red -fg bogus
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {unknown color name "bogus"}
+test button-5.2 {ConfigureButton - textvariable trace} -body {
+ button .b -bd 4 -bg green
+ catch {.b configure -bd 7 -bg red -fg bogus}
+ list [.b cget -bd] [.b cget -bg]
+} -cleanup {
+ destroy .b
+} -result {4 green}
+test button-5.3 {ConfigureButton - textvariable trace} -body {
+ button .b -textvariable x
set x From-x
set y From-y
- button .b1 -textvariable x
- .b1 configure -textvariable y
+ .b configure -textvariable y
set x New
- lindex [.b1 configure -text] 4
-} {From-y}
-test button-6.2a {ConfigureButton - variable traces} {
- catch {destroy .b1}
- catch {unset x}
- checkbutton .b1 -variable x
+ lindex [.b configure -text] 4
+} -cleanup {
+ destroy .b
+} -result {From-y}
+test button-5.4 {ConfigureButton - variable trace} -body { ;# ex 6.2a
+ checkbutton .c -variable x
set x 1
set y 1
- .b1 configure -textvariable y
+ .c configure -textvariable y
set x 0
- .b1 toggle
- set y
-} {1}
-test button-6.3 {ConfigureButton - image handling} testImageType {
- catch {destroy .b1}
- eval image delete [image names]
+ .c toggle
+ return $y
+} -cleanup {
+ destroy .c
+} -result {1}
+
+test button-5.5 {ConfigureButton - image handling} -constraints {
+ testImageType
+} -setup {
+ imageCleanup
image create test image1
image create test image2
- button .b1 -image image1
+} -body {
+ button .b -image image1
image delete image1
- .b1 configure -image image2
- image names
-} {image2}
-test button-6.5 {ConfigureButton - default value for variable} {
- catch {destroy .b1}
- checkbutton .b1
- .b1 cget -variable
-} {b1}
-test button-6.6 {ConfigureButton - setting selected state from variable} {
- catch {destroy .b1}
+ .b configure -image image2
+ imageNames
+} -cleanup {
+ destroy .b
+ imageCleanup
+} -result {image2}
+
+test button-5.6 {ConfigureButton - default value for variable} -body {
+ checkbutton .c
+ .c cget -variable
+} -cleanup {
+ destroy .c
+} -result {c}
+test button-5.7 {ConfigureButton - setting selected state from variable} -body {
set x 0
set y Shiny
- checkbutton .b1 -variable x
- .b1 configure -variable y -onvalue Shiny
- .b1 toggle
- set y
-} 0
-test button-6.7 {ConfigureButton - setting selected state from variable} {
- catch {destroy .b1}
- catch {unset x}
- checkbutton .b1 -variable x -offvalue Bogus
- set x
-} Bogus
-test button-6.8 {ConfigureButton - setting selected state from variable} {
- catch {destroy .b1}
- catch {unset x}
- radiobutton .b1 -variable x
- set x
-} {}
-test button-6.9 {ConfigureButton - error in setting variable} {
- catch {destroy .b1}
- catch {unset x}
+ checkbutton .c -variable x
+ .c configure -variable y -onvalue Shiny
+ .c toggle
+ return $y
+} -cleanup {
+ destroy .c
+} -result {0}
+test button-5.8 {ConfigureButton - setting selected state from variable} -setup {
+ unset -nocomplain x
+} -body {
+ checkbutton .c -variable x -offvalue Bogus
+ return $x
+} -cleanup {
+ destroy .c
+} -result {Bogus}
+
+test button-5.9 {ConfigureButton - setting selected state from variable} -setup {
+ unset -nocomplain x
+} -body {
+ radiobutton .r -variable x
+ return $x
+} -cleanup {
+ destroy .r
+} -result {}
+
+test button-5.10 {ConfigureButton - error in setting variable} -setup {
+ unset -nocomplain x
+} -body {
trace variable x w bogusTrace
- set result [list [catch {radiobutton .b1 -variable x} msg] $msg]
+ radiobutton .r -variable x
+} -cleanup {
+ destroy .r
trace vdelete x w bogusTrace
- set result
-} {1 {can't set "x": trace aborted}}
-test button-6.10 {ConfigureButton - bad image name} {
- catch {destroy .b1}
- list [catch {button .b1 -image bogus} msg] $msg
-} {1 {image "bogus" doesn't exist}}
-test button-6.11 {ConfigureButton - setting variable from current text value} {
- catch {destroy .b1}
- catch {unset x}
- button .b1 -textvariable x -text "Button 1"
- set x
-} {Button 1}
-test button-6.12 {ConfigureButton - using current value of variable} {
- catch {destroy .b1}
+} -returnCodes {error} -result {can't set "x": trace aborted}
+
+test button-5.11 {ConfigureButton - bad image name} -body {
+ button .b -image bogus
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {image "bogus" doesn't exist}
+
+test button-5.12 {ConfigureButton - setting variable from current text value} -setup {
+ unset -nocomplain x
+} -body {
+ button .b -textvariable x -text "Button 1"
+ return $x
+} -cleanup {
+ destroy .b
+} -result {Button 1}
+
+test button-5.13 {ConfigureButton - using current value of variable} -body {
set x Override
- button .b1 -textvariable x -text "Button 1"
- set x
-} {Override}
-test button-6.13 {ConfigureButton - variable handling} {
- catch {destroy .b1}
- catch {unset x}
+ button .b -textvariable x -text "Button 1"
+ return $x
+} -cleanup {
+ destroy .b
+} -result {Override}
+
+test button-5.14 {ConfigureButton - variable handling} -setup {
+ unset -nocomplain x
+} -body {
+ trace variable x w bogusTrace
+ radiobutton .r -text foo -textvariable x
+} -cleanup {
+ trace vdelete x w bogusTrace
+ destroy .r
+} -returnCodes {error} -result {can't set "x": trace aborted}
+test button-5.15 {ConfigureButton - variable handling} -setup {
+ unset -nocomplain x
+} -body {
trace variable x w bogusTrace
- set result [list [catch {radiobutton .b1 -text foo -textvariable x} msg] \
- $msg $x]
+ catch {radiobutton .r -text foo -textvariable x}
+ return $x
+} -cleanup {
trace vdelete x w bogusTrace
- set result
-} {1 {can't set "x": trace aborted} foo}
-test button-6.14 {ConfigureButton - -width option} {
- catch {destroy .b1}
- button .b1 -text "Button 1"
- list [catch {.b1 configure -width 1i} msg] $msg $errorInfo
-} {1 {expected integer but got "1i"} {expected integer but got "1i"
+ destroy .r
+} -result {foo}
+
+#ex 6.14
+test button-5.16 {ConfigureButton - -width option} -body {
+ button .b -text "Button 1"
+ .b configure -width 1i
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {expected integer but got "1i"}
+test button-5.17 {ConfigureButton - -width option} -body {
+ button .b -text "Button 1"
+ catch {.b configure -width 1i}
+ return $errorInfo
+} -cleanup {
+ destroy .b
+} -result {expected integer but got "1i"
(processing -width option)
invoked from within
-".b1 configure -width 1i"}}
-test button-6.15 {ConfigureButton - -height option} {
- catch {destroy .b1}
- button .b1 -text "Button 1"
- list [catch {.b1 configure -height 0.5c} msg] $msg $errorInfo
-} {1 {expected integer but got "0.5c"} {expected integer but got "0.5c"
+".b configure -width 1i"}
+test button-5.18 {ConfigureButton - -height option} -body {
+ button .b -text "Button 1"
+ .b configure -height 0.5c
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {expected integer but got "0.5c"}
+test button-5.19 {ConfigureButton - -height option} -body {
+ button .b -text "Button 1"
+ catch {.b configure -height 0.5c}
+ return $errorInfo
+} -cleanup {
+ destroy .b
+} -result {expected integer but got "0.5c"
(processing -height option)
invoked from within
-".b1 configure -height 0.5c"}}
-test button-6.16 {ConfigureButton - -width option} {
- catch {destroy .b1}
- button .b1 -bitmap questhead
- list [catch {.b1 configure -width abc} msg] $msg $errorInfo
-} {1 {bad screen distance "abc"} {bad screen distance "abc"
+".b configure -height 0.5c"}
+#ex 6.16
+test button-5.20 {ConfigureButton - -width option} -body {
+ button .b -bitmap questhead
+ .b configure -width abc
+} -cleanup {
+ destroy .b
+} -returnCodes {error} -result {bad screen distance "abc"}
+test button-5.21 {ConfigureButton - -width option} -body {
+ button .b -bitmap questhead
+ catch {.b configure -width abc}
+ return $errorInfo
+} -cleanup {
+ destroy .b
+} -result {bad screen distance "abc"
(processing -width option)
invoked from within
-".b1 configure -width abc"}}
-test button-6.17 {ConfigureButton - -height option} testImageType {
- catch {destroy .b1}
- eval image delete [image names]
+".b configure -width abc"}
+test button-5.22 {ConfigureButton - -height option} -constraints {
+ testImageType
+} -setup {
image create test image1
- button .b1 -image image1
- list [catch {.b1 configure -height 0.5x} msg] $msg $errorInfo
-} {1 {bad screen distance "0.5x"} {bad screen distance "0.5x"
+} -body {
+ button .b -image image1
+ .b configure -height 0.5x
+} -cleanup {
+ destroy .b
+ image delete image1
+} -returnCodes {error} -result {bad screen distance "0.5x"}
+test button-5.23 {ConfigureButton - -height option} -constraints {
+ testImageType
+} -setup {
+ image create test image1
+} -body {
+#ztestImageType
+ button .b -image image1
+ catch {.b configure -height 0.5x}
+ return $errorInfo
+} -cleanup {
+ destroy .b
+ image delete image1
+} -result {bad screen distance "0.5x"
(processing -height option)
invoked from within
-".b1 configure -height 0.5x"}}
-test button-6.18 {ConfigureButton - computing geometry} {nonPortable fonts} {
- catch {destroy .b1}
- button .b1 -text "Sample text" -width 10 -height 2
- pack .b1
- set result "[winfo reqwidth .b1] [winfo reqheight .b1]"
- .b1 configure -bitmap questhead
- lappend result [winfo reqwidth .b1] [winfo reqheight .b1]
-} {102 46 20 12}
-test button-6.19 {ConfigureButton - computing geometry} {
- catch {destroy .b1}
- button .b1 -text "Button 1"
- set old [winfo reqwidth .b1]
- .b1 configure -text "Much longer text"
- set new [winfo reqwidth .b1]
- expr $old == $new
-} {0}
-
-test button-7.1 {ButtonEventProc procedure} {
- catch {destroy .b1}
- button .b1 -text "Test Button" -command {
- destroy .b1
- set x [list [winfo exists .b1] [info commands .b1]]
- }
- .b1 invoke
- set x
-} {0 {}}
-test button-7.2 {ButtonEventProc procedure} {
- deleteWindows
+".b configure -height 0.5x"}
+#ex 6.18
+test button-5.24 {ConfigureButton - computing geometry} -constraints {
+ fonts
+} -body {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ .b configure -text "Sample text" -width 10 -height 2
+ pack .b
+ set result "[winfo reqwidth .b] [winfo reqheight .b]"
+ .b configure -bitmap questhead
+ lappend result [winfo reqwidth .b] [winfo reqheight .b]
+} -cleanup {
+ destroy .b
+} -result {104 46 20 12}
+
+test button-5.25 {ConfigureButton - computing geometry} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+} -body {
+ .b configure -text "Button 1"
+ set old [winfo reqwidth .b]
+ .b configure -text "Much longer text"
+ set new [winfo reqwidth .b]
+ expr {$old == $new}
+} -cleanup {
+ destroy .b
+} -result {0}
+
+test button-6.1 {ButtonEventProc procedure} -body {
+ button .b -text "Test Button" -command {
+ destroy .b
+ set x [list [winfo exists .b] [info commands .b]]
+}
+ .b invoke
+ return $x
+} -cleanup {
+ destroy .b
+} -result {0 {}}
+
+test button-6.2 {ButtonEventProc procedure} -setup {
+ set x {}
+} -body {
button .b1 -bg #543210
rename .b1 .b2
- set x {}
lappend x [winfo children .]
lappend x [.b2 cget -bg]
destroy .b1
lappend x [info command .b*] [winfo children .]
-} {.b1 #543210 {} {}}
+} -cleanup {
+ destroy .b1
+} -result {.b1 #543210 {} {}}
-test button-8.1 {ButtonCmdDeletedProc procedure} {
- deleteWindows
- button .b1
- rename .b1 {}
+test button-7.1 {ButtonCmdDeletedProc procedure} -body {
+ button .b
+ rename .b {}
list [info command .b*] [winfo children .]
-} {{} {}}
+} -cleanup {
+ destroy .b
+} -result {{} {}}
-test button-9.1 {TkInvokeButton procedure} {
- catch {destroy .b1}
+test button-8.1 {TkInvokeButton procedure} -setup {
set x 0
- checkbutton .b1 -variable x
+} -body {
+ checkbutton .c -variable x
set result $x
- .b1 invoke
+ .c invoke
lappend result $x
- .b1 invoke
+ .c invoke
lappend result $x
-} {0 1 0}
-test button-9.2 {TkInvokeButton procedure} {
- catch {destroy .b1}
+} -cleanup {
+ destroy .c
+} -result {0 1 0}
+
+test button-8.2 {TkInvokeButton procedure} -setup {
+ set x 0
+} -body {
+ checkbutton .c -variable x
+ trace variable x w bogusTrace
+ .c invoke
+} -cleanup {
+ destroy .c
+ trace vdelete x w bogusTrace
+} -returnCodes {error} -result {can't set "x": trace aborted}
+test button-8.3 {TkInvokeButton procedure} -setup {
set x 0
- checkbutton .b1 -variable x
+} -body {
+ checkbutton .c -variable x
trace variable x w bogusTrace
- set result [list [catch {.b1 invoke} msg] $msg $x]
+ catch {.c invoke}
+ return $x
+} -cleanup {
+ destroy .c
trace vdelete x w bogusTrace
- set result
-} {1 {can't set "x": trace aborted} 1}
-test button-9.3 {TkInvokeButton procedure} {
- catch {destroy .b1}
+} -result {1}
+test button-8.4 {TkInvokeButton procedure} -setup {
set x 1
- checkbutton .b1 -variable x
+} -body {
+ checkbutton .c -variable x
trace variable x w bogusTrace
- set result [list [catch {.b1 invoke} msg] $msg $x]
+ .c invoke
+} -cleanup {
+ destroy .c
+ trace vdelete x w bogusTrace
+} -returnCodes {error} -result {can't set "x": trace aborted}
+test button-8.5 {TkInvokeButton procedure} -setup {
+ set x 1
+} -body {
+ checkbutton .c -variable x
+ trace variable x w bogusTrace
+ catch {.c invoke}
+ return $x
+} -cleanup {
+ destroy .c
trace vdelete x w bogusTrace
- set result
-} {1 {can't set "x": trace aborted} 0}
-test button-9.4 {TkInvokeButton procedure} {
- catch {destroy .b1}
+} -result {0}
+
+test button-8.6 {TkInvokeButton procedure} -setup {
set x 0
- radiobutton .b1 -variable x -value red
+} -body {
+ radiobutton .r -variable x -value red
set result $x
- .b1 invoke
+ .r invoke
lappend result $x
- .b1 invoke
+ .r invoke
lappend result $x
-} {0 red red}
-test button-9.5 {TkInvokeButton procedure} -body {
- catch {destroy .b1}
- radiobutton .b1 -variable x -value red
+} -cleanup {
+ destroy .r
+} -result {0 red red}
+
+test button-8.7 {TkInvokeButton procedure} -body {
+ radiobutton .r -variable x -value red
+ set x green
+ trace variable x w bogusTrace
+ .r invoke
+} -cleanup {
+ destroy .r
+ trace vdelete x w bogusTrace
+} -returnCodes {error} -result {can't set "x": trace aborted}
+test button-8.8 {TkInvokeButton procedure} -body {
+ radiobutton .r -variable x -value red
set x green
trace variable x w bogusTrace
- set result [list [catch {.b1 invoke} msg] $msg $errorInfo $x]
+ catch {.r invoke}
+ list $errorInfo $x
+} -cleanup {
+ destroy .r
trace vdelete x w bogusTrace
- set result
-} -match glob -result {1 {can't set "x": trace aborted} {*trace aborted
+} -match {glob} -result {{*trace aborted
while executing
*
-".b1 invoke"} red}
-test button-9.6 {TkInvokeButton procedure} {
- deleteWindows
+".r invoke"} red}
+
+#ex 9.6
+test button-8.9 {TkInvokeButton procedure} -setup {
set result untouched
- button .b1 -command {set result invoked}
- list [catch {.b1 invoke} msg] $msg $result
-} {0 invoked invoked}
-test button-9.7 {TkInvokeButton procedure} {
- deleteWindows
+} -body {
+ button .b -command {set result invoked}
+ set msg [.b invoke]
+ list $msg $result
+} -cleanup {
+ destroy .b
+} -result {invoked invoked}
+test button-8.10 {TkInvokeButton procedure} -setup {
set result untouched
set x 0
- checkbutton .b1 -variable x -command {set result "invoked $x"}
- list [catch {.b1 invoke} msg] $msg $result
-} {0 {invoked 1} {invoked 1}}
-test button-9.8 {TkInvokeButton procedure} {
- deleteWindows
+} -body {
+ checkbutton .c -variable x -command {set result "invoked $x"}
+ set msg [.c invoke]
+ list $msg $result
+} -cleanup {
+ destroy .c
+} -result {{invoked 1} {invoked 1}}
+test button-8.11 {TkInvokeButton procedure} -setup {
set result untouched
set x 0
- radiobutton .b1 -variable x -value red -command {set result "invoked $x"}
- list [catch {.b1 invoke} msg] $msg $result
-} {0 {invoked red} {invoked red}}
+} -body {
+ radiobutton .r -variable x -value red -command {set result "invoked $x"}
+ set msg [.r invoke]
+ list $msg $result
+} -cleanup {
+ destroy .r
+} -result {{invoked red} {invoked red}}
-test button-10.1 {ButtonVarProc procedure} {
- deleteWindows
+test button-9.1 {ButtonVarProc procedure} -body {
set x 1
- checkbutton .b1 -variable x
+ checkbutton .c -variable x
unset x
set result [info exists x]
- .b1 toggle
+ .c toggle
lappend result $x
set x 0
- .b1 toggle
+ .c toggle
lappend result $x
-} {0 1 1}
-test button-10.2 {ButtonVarProc procedure} {
- deleteWindows
+} -cleanup {
+ destroy .c
+} -result {0 1 1}
+test button-9.2 {ButtonVarProc procedure} -body {
set x 0
- checkbutton .b1 -variable x
+ checkbutton .c -variable x
set x 44
- .b1 toggle
- set x
-} {1}
-test button-10.3 {ButtonVarProc procedure} {
- deleteWindows
+ .c toggle
+ return $x
+} -cleanup {
+ destroy .c
+} -result {1}
+test button-9.3 {ButtonVarProc procedure} -setup {
set x 1
- checkbutton .b1 -variable x
+} -body {
+ checkbutton .c -variable x
set x 44
- .b1 toggle
- set x
-} {1}
-test button-10.4 {ButtonVarProc procedure} {
- deleteWindows
+ .c toggle
+ return $x
+} -cleanup {
+ destroy .c
+} -result {1}
+test button-9.4 {ButtonVarProc procedure} -setup {
set x 0
- checkbutton .b1 -variable x
+} -body {
+ checkbutton .c -variable x
set x 1
- .b1 toggle
- set x
-} {0}
-test button-10.5 {ButtonVarProc procedure} {
- deleteWindows
+ .c toggle
+ return $x
+} -cleanup {
+ destroy .c
+} -result {0}
+test button-9.5 {ButtonVarProc procedure} -setup {
set x 1
- checkbutton .b1 -variable x
+} -body {
+ checkbutton .c -variable x
set x 1
- .b1 toggle
- set x
-} {0}
-test button-10.6 {ButtonVarProc procedure} {
- deleteWindows
+ .c toggle
+ return $x
+} -cleanup {
+ destroy .c
+} -result {0}
+test button-9.6 {ButtonVarProc procedure} -setup {
set x 0
- checkbutton .b1 -variable x
+} -body {
+ checkbutton .c -variable x
set x 0
- .b1 toggle
- set x
-} {1}
-test button-10.7 {ButtonVarProc procedure} {
- deleteWindows
+ .c toggle
+ return $x
+} -cleanup {
+ destroy .c
+} -result {1}
+test button-9.7 {ButtonVarProc procedure} -setup {
set x 1
- checkbutton .b1 -variable x
+} -body {
+ checkbutton .c -variable x
set x 0
- .b1 toggle
- set x
-} {1}
-test button-10.8 {ButtonVarProc procedure, can't read variable} {
- # This test does nothing but produce a core dump if there's a prbblem.
- deleteWindows
- catch {unset a}
- checkbutton .b1 -variable a
+ .c toggle
+ return $x
+} -cleanup {
+ destroy .c
+} -result {1}
+test button-9.8 {ButtonVarProc procedure, can't read variable} -setup {
+# This test does nothing but produce a core dump if there's a prbblem.
+ unset -nocomplain a
+} -body {
+ checkbutton .c -variable a
unset a
set a(32) 0
unset a
-} {}
+} -cleanup {
+ destroy .c
+} -result {}
-test button-11.1 {ButtonTextVarProc procedure} {
- deleteWindows
+test button-10.1 {ButtonTextVarProc procedure} -body {
set x Label
- button .b1 -textvariable x
+ button .b -textvariable x
unset x
- set result [list $x [lindex [.b1 configure -text] 4]]
+ set result [list $x [.b cget -text]]
set x New
- lappend result [lindex [.b1 configure -text] 4]
-} {Label Label New}
-test button-11.2 {ButtonTextVarProc procedure} {
- deleteWindows
- # Windows buttons have a default min width, so we have to
- # set this to be longer to force the wider button.
+ lappend result [.b cget -text]
+} -cleanup {
+ destroy .b
+} -result {Label Label New}
+test button-10.2 {ButtonTextVarProc procedure} -setup {
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+} -body {
+# Windows buttons have a default min width, so we have to
+# set this to be longer to force the wider button.
set x ExtraLongLabel
- button .b1 -textvariable x
- set old [winfo reqwidth .b1]
+ .b configure -textvariable x
+ set old [winfo reqwidth .b]
set x New
- set new [winfo reqwidth .b1]
- list [lindex [.b1 configure -text] 4] [expr $old == $new]
-} {New 0}
+ set new [winfo reqwidth .b]
+ expr {$old == $new}
+} -cleanup {
+ destroy .b
+} -result {0}
-test button-12.1 {ButtonImageProc procedure} testImageType {
- deleteWindows
- eval image delete [image names]
+test button-11.1 {ButtonImageProc procedure} -constraints {
+ testImageType
+} -setup {
+ label .l -highlightthickness 0 -font {Helvetica -12 bold}
image create test image1
- label .b1 -image image1 -padx 0 -pady 0 -bd 0
- pack .b1
- set result "[winfo reqwidth .b1] [winfo reqheight .b1]"
+} -body {
+ .l configure -image image1 -padx 0 -pady 0 -bd 0
+ pack .l
+ set result "[winfo reqwidth .l] [winfo reqheight .l]"
image1 changed 0 0 0 0 80 100
- lappend result [winfo reqwidth .b1] [winfo reqheight .b1]
-} {30 15 80 100}
-
-deleteWindows
-set l [interp hidden]
+ lappend result [winfo reqwidth .l] [winfo reqheight .l]
+} -cleanup {
+ destroy .l
+ image delete image1
+} -result {30 15 80 100}
-test button-13.1 {button widget vs hidden commands} {
- catch {destroy .b}
+test button-12.1 {button widget vs hidden commands} -body {
button .b -text hello
+ set l [interp hidden]
interp hide {} .b
destroy .b
- list [winfo children .] [interp hidden]
-} [list {} $l]
-
-deleteWindows
-
-test button-14.1 {size behaviouor} {
- set res {}
- foreach class {label button radiobutton checkbutton} {
- eval destroy [winfo children .]
-
- $class .a -text Hej
- $class .b -text Hej -width 10 -height 1
- $class .c -text "" -width 10 -height 1
-
- for {set t 0} {$t < 2} {incr t} {
- set res2 {}
- # With -width, width should not be affected by text change
- lappend res2 [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}]
- # With -height, height should not be affected by text change
- lappend res2 [expr {[winfo reqheight .b] == [winfo reqheight .c]}]
- # A one line text should be as high as -height 1
- lappend res2 [expr {[winfo reqheight .a] == [winfo reqheight .b]}]
- lappend res $res2
-
- # Do the second round with another font
- .a configure -font "Arial 20"
- .b configure -font "Arial 20"
- .c configure -font "Arial 20"
- }
- }
- set res
-} {{1 1 1} {1 1 1} {1 1 1} {1 1 1} {1 1 1} {1 1 1} {1 1 1} {1 1 1}}
-
-deleteWindows
-
-option clear
-
-# cleanup
+
+ set res1 [list [winfo children .] [interp hidden]]
+ set res2 [list {} $l]
+ expr {$res1 == $res2}
+} -cleanup {
+ destroy .b
+} -result {1}
+
+test button-13.1 {size behaviouor: label} -setup {
+ label .a -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ label .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ label .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ set result {}
+} -body {
+ .a configure -text Hej
+ .b configure -text Hej -width 10 -height 1
+ .c configure -text "" -width 10 -height 1
+
+# With -width, width should not be affected by text change
+ lappend result [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}]
+# With -height, height should not be affected by text change
+ lappend result [expr {[winfo reqheight .b] == [winfo reqheight .c]}]
+# A one line text should be as high as -height 1
+ lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}]
+} -cleanup {
+ destroy .a .b .c
+} -result {1 1 1}
+test button-13.2 {size behaviouor: label} -setup {
+ label .a -borderwidth 2 -highlightthickness 2 -font {Arial 20}
+ label .b -borderwidth 2 -highlightthickness 2 -font {Arial 20}
+ label .c -borderwidth 2 -highlightthickness 2 -font {Arial 20}
+ set result {}
+} -body {
+ .a configure -text Hej
+ .b configure -text Hej -width 10 -height 1
+ .c configure -text "" -width 10 -height 1
+
+# With -width, width should not be affected by text change
+ lappend result [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}]
+# With -height, height should not be affected by text change
+ lappend result [expr {[winfo reqheight .b] == [winfo reqheight .c]}]
+# A one line text should be as high as -height 1
+ lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}]
+} -cleanup {
+ destroy .a .b .c
+} -result {1 1 1}
+
+test button-13.3 {size behaviouor: button} -setup {
+ button .a -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ button .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ set result {}
+} -body {
+ .a configure -text Hej
+ .b configure -text Hej -width 10 -height 1
+ .c configure -text "" -width 10 -height 1
+
+# With -width, width should not be affected by text change
+ lappend result [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}]
+# With -height, height should not be affected by text change
+ lappend result [expr {[winfo reqheight .b] == [winfo reqheight .c]}]
+# A one line text should be as high as -height 1
+ lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}]
+} -cleanup {
+ destroy .a .b .c
+} -result {1 1 1}
+test button-13.4 {size behaviouor: button} -setup {
+ button .a -borderwidth 2 -highlightthickness 2 -font {Arial 20}
+ button .b -borderwidth 2 -highlightthickness 2 -font {Arial 20}
+ button .c -borderwidth 2 -highlightthickness 2 -font {Arial 20}
+ set result {}
+} -body {
+ .a configure -text Hej
+ .b configure -text Hej -width 10 -height 1
+ .c configure -text "" -width 10 -height 1
+
+# With -width, width should not be affected by text change
+ lappend result [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}]
+# With -height, height should not be affected by text change
+ lappend result [expr {[winfo reqheight .b] == [winfo reqheight .c]}]
+# A one line text should be as high as -height 1
+ lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}]
+} -cleanup {
+ destroy .a .b .c
+} -result {1 1 1}
+
+test button-13.5 {size behaviouor: radiobutton} -setup {
+ radiobutton .a -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ radiobutton .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ radiobutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ set result {}
+} -body {
+ .a configure -text Hej
+ .b configure -text Hej -width 10 -height 1
+ .c configure -text "" -width 10 -height 1
+
+# With -width, width should not be affected by text change
+ lappend result [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}]
+# With -height, height should not be affected by text change
+ lappend result [expr {[winfo reqheight .b] == [winfo reqheight .c]}]
+# A one line text should be as high as -height 1
+ lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}]
+} -cleanup {
+ destroy .a .b .c
+} -result {1 1 1}
+
+test button-13.6 {size behaviouor: radiobutton} -setup {
+ radiobutton .a -borderwidth 2 -highlightthickness 2 -font {Arial 20}
+ radiobutton .b -borderwidth 2 -highlightthickness 2 -font {Arial 20}
+ radiobutton .c -borderwidth 2 -highlightthickness 2 -font {Arial 20}
+ set result {}
+} -body {
+ .a configure -text Hej
+ .b configure -text Hej -width 10 -height 1
+ .c configure -text "" -width 10 -height 1
+
+# With -width, width should not be affected by text change
+ lappend result [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}]
+# With -height, height should not be affected by text change
+ lappend result [expr {[winfo reqheight .b] == [winfo reqheight .c]}]
+# A one line text should be as high as -height 1
+ lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}]
+} -cleanup {
+ destroy .a .b .c
+} -result {1 1 1}
+
+test button-13.7 {size behaviouor: checkbutton} -setup {
+ checkbutton .a -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ checkbutton .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ set result {}
+} -body {
+ .a configure -text Hej
+ .b configure -text Hej -width 10 -height 1
+ .c configure -text "" -width 10 -height 1
+
+# With -width, width should not be affected by text change
+ lappend result [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}]
+# With -height, height should not be affected by text change
+ lappend result [expr {[winfo reqheight .b] == [winfo reqheight .c]}]
+# A one line text should be as high as -height 1
+ lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}]
+} -cleanup {
+ destroy .a .b .c
+} -result {1 1 1}
+
+test button-13.8 {size behaviouor: checkbutton} -setup {
+ checkbutton .a -borderwidth 2 -highlightthickness 2 -font {Arial 20}
+ checkbutton .b -borderwidth 2 -highlightthickness 2 -font {Arial 20}
+ checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Arial 20}
+ set result {}
+} -body {
+ .a configure -text Hej
+ .b configure -text Hej -width 10 -height 1
+ .c configure -text "" -width 10 -height 1
+
+# With -width, width should not be affected by text change
+ lappend result [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}]
+# With -height, height should not be affected by text change
+ lappend result [expr {[winfo reqheight .b] == [winfo reqheight .c]}]
+# A one line text should be as high as -height 1
+ lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}]
+} -cleanup {
+ destroy .a .b .c
+} -result {1 1 1}
+
+imageFinish
cleanupTests
return
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tests/canvImg.test b/tests/canvImg.test
index 1dffc5e..776d268 100644
--- a/tests/canvImg.test
+++ b/tests/canvImg.test
@@ -7,103 +7,161 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
+imageInit
-eval image delete [image names]
+# Canvas used in every test case of the whole file
canvas .c
pack .c
update
-if {[testConstraint testImageType]} {
- image create test foo -variable x
- image create test foo2 -variable y
- foo2 changed 0 0 0 0 80 60
-}
-test canvImg-1.1 {options for image items} {
- .c delete all
+
+
+test canvImg-1.1 {options for image items} -body {
.c create image 50 50 -anchor nw -tags i1
.c itemconfigure i1 -anchor
-} {-anchor {} {} center nw}
-test canvImg-1.2 {options for image items} {
- .c delete all
- list [catch {.c create image 50 50 -anchor gorp -tags i1} msg] $msg
-} {1 {bad anchor position "gorp": must be n, ne, e, se, s, sw, w, nw, or center}}
-test canvImg-1.3 {options for image items} testImageType {
- .c delete all
+} -cleanup {
+ .c delete all
+} -result {-anchor {} {} center nw}
+test canvImg-1.2 {options for image items} -body {
+ .c create image 50 50 -anchor gorp -tags i1
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {bad anchor position "gorp": must be n, ne, e, se, s, sw, w, nw, or center}
+test canvImg-1.3 {options for image items} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
.c create image 50 50 -image foo -tags i1
.c itemconfigure i1 -image
-} {-image {} {} {} foo}
-test canvImg-1.4 {options for image items} {
- .c delete all
- list [catch {.c create image 50 50 -image unknown -tags i1} msg] $msg
-} {1 {image "unknown" doesn't exist}}
-test canvImg-1.5 {options for image items} testImageType {
- .c delete all
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {-image {} {} {} foo}
+test canvImg-1.4 {options for image items} -body {
+ .c create image 50 50 -image unknown -tags i1
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {image "unknown" doesn't exist}
+test canvImg-1.5 {options for image items} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
.c create image 50 50 -image foo -tags {i1 foo}
.c itemconfigure i1 -tags
-} {-tags {} {} {} {i1 foo}}
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {-tags {} {} {} {i1 foo}}
-test canvImg-2.1 {CreateImage procedure} {
- list [catch {.c create image 40} msg] $msg
-} {1 {wrong # coordinates: expected 2, got 1}}
-test canvImg-2.2 {CreateImage procedure} {
- list [catch {.c create image 40 50 60} msg] $msg
-} {1 {unknown option "60"}}
-test canvImg-2.3 {CreateImage procedure} {
+test canvImg-2.1 {CreateImage procedure} -body {
+ .c create image 40
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {wrong # coordinates: expected 2, got 1}
+test canvImg-2.2 {CreateImage procedure} -body {
+ .c create image 40 50 60
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {unknown option "60"}
+test canvImg-2.3 {CreateImage procedure} -body {
.c delete all
set i [.c create image 50 50]
list [lindex [.c itemconf $i -anchor] 4] \
[lindex [.c itemconf $i -image] 4] \
[lindex [.c itemconf $i -tags] 4]
-} {center {} {}}
-test canvImg-2.4 {CreateImage procedure} {
- list [catch {.c create image xyz 40} msg] $msg
-} {1 {bad screen distance "xyz"}}
-test canvImg-2.5 {CreateImage procedure} {
- list [catch {.c create image 50 qrs} msg] $msg
-} {1 {bad screen distance "qrs"}}
-test canvImg-2.6 {CreateImage procedure} testImageType {
- list [catch {.c create image 50 50 -gorp foo} msg] $msg
-} {1 {unknown option "-gorp"}}
-
-test canvImg-3.1 {ImageCoords procedure} testImageType {
+} -cleanup {
.c delete all
- .c create image 50 100 -image foo -tags i1
- .c coords i1
-} {50.0 100.0}
-test canvImg-3.2 {ImageCoords procedure} testImageType {
+} -result {center {} {}}
+test canvImg-2.4 {CreateImage procedure} -body {
+ .c create image xyz 40
+} -cleanup {
.c delete all
+} -returnCodes {error} -result {bad screen distance "xyz"}
+test canvImg-2.5 {CreateImage procedure} -body {
+ .c create image 50 qrs
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {bad screen distance "qrs"}
+test canvImg-2.6 {CreateImage procedure} -constraints testImageType -body {
+ .c create image 50 50 -gorp foo
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {unknown option "-gorp"}
+
+
+test canvImg-3.1 {ImageCoords procedure} -constraints testImageType -setup {
+ image create test foo
+} -body {
+ .c create image 50 100 -image foo -tags i1
+ format {%.6g %.6g} {*}[.c coords i1]
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {50 100}
+test canvImg-3.2 {ImageCoords procedure} -constraints testImageType -setup {
+ image create test foo
+} -body {
.c create image 50 100 -image foo -tags i1
- list [catch {.c coords i1 dumb 100} msg] $msg
-} {1 {bad screen distance "dumb"}}
-test canvImg-3.3 {ImageCoords procedure} testImageType {
+ .c coords i1 dumb 100
+} -cleanup {
+ .c delete all
+ image delete foo
+} -returnCodes {error} -result {bad screen distance "dumb"}
+test canvImg-3.3 {ImageCoords procedure} -constraints testImageType -setup {
+ image create test foo
+} -body {
.c delete all
.c create image 50 100 -image foo -tags i1
- list [catch {.c coords i1 250 dumb0} msg] $msg
-} {1 {bad screen distance "dumb0"}}
-test canvImg-3.4 {ImageCoords procedure} testImageType {
+ .c coords i1 250 dumb0
+} -cleanup {
+ .c delete all
+ image delete foo
+} -returnCodes {error} -result {bad screen distance "dumb0"}
+test canvImg-3.4 {ImageCoords procedure} -constraints testImageType -setup {
+ image create test foo
+} -body {
.c delete all
.c create image 50 100 -image foo -tags i1
- list [catch {.c coords i1 250} msg] $msg
-} {1 {wrong # coordinates: expected 2, got 1}}
-test canvImg-3.5 {ImageCoords procedure} testImageType {
+ .c coords i1 250
+} -cleanup {
+ .c delete all
+ image delete foo
+} -returnCodes {error} -result {wrong # coordinates: expected 2, got 1}
+test canvImg-3.5 {ImageCoords procedure} -constraints testImageType -setup {
+ image create test foo
+} -body {
.c delete all
.c create image 50 100 -image foo -tags i1
- list [catch {.c coords i1 250 300 400} msg] $msg
-} {1 {wrong # coordinates: expected 0 or 2, got 3}}
+ .c coords i1 250 300 400
+} -cleanup {
+ .c delete all
+ image delete foo
+} -returnCodes {error} -result {wrong # coordinates: expected 0 or 2, got 3}
+
-test canvImg-4.1 {ConfiugreImage procedure} testImageType {
+test canvImg-4.1 {ConfiugreImage procedure} -constraints testImageType -setup {
.c delete all
+} -body {
+ image create test foo -variable x
.c create image 50 100 -image foo -tags i1
update
set x {}
.c itemconfigure i1 -image {}
update
list $x [.c bbox i1]
-} {{{foo free}} {}}
-test canvImg-4.2 {ConfiugreImage procedure} testImageType {
- .c delete all
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {{{foo free}} {}}
+test canvImg-4.2 {ConfiugreImage procedure} -constraints testImageType -setup {
+ .c delete all
+} -body {
+ image create test foo -variable x
+ image create test foo2 -variable y
+ foo2 changed 0 0 0 0 80 60
.c create image 50 100 -image foo -tags i1 -anchor nw
update
set x {}
@@ -111,281 +169,628 @@ test canvImg-4.2 {ConfiugreImage procedure} testImageType {
.c itemconfigure i1 -image foo2
update
list $x $y [.c bbox i1]
-} {{{foo free}} {{foo2 get} {foo2 display 0 0 80 60 30 30}} {50 100 130 160}}
-test canvImg-4.3 {ConfiugreImage procedure} testImageType {
- .c delete all
+} -cleanup {
+ .c delete all
+ image delete foo
+ image delete foo2
+} -result {{{foo free}} {{foo2 get} {foo2 display 0 0 80 60 30 30}} {50 100 130 160}}
+test canvImg-4.3 {ConfiugreImage procedure} -constraints testImageType -setup {
+ .c delete all
+} -body {
+ image create test foo -variable x
+ image create test foo2 -variable y
+ foo2 changed 0 0 0 0 80 60
.c create image 50 100 -image foo -tags i1 -anchor nw
update
set x {}
set y {}
- list [catch {.c itemconfigure i1 -image lousy} msg] $msg
-} {1 {image "lousy" doesn't exist}}
+ .c itemconfigure i1 -image lousy
+} -cleanup {
+ .c delete all
+ image delete foo foo2
+} -returnCodes {error} -result {image "lousy" doesn't exist}
-test canvImg-5.1 {DeleteImage procedure} testImageType {
- image create test xyzzy -variable z
+
+test canvImg-5.1 {DeleteImage procedure} -constraints testImageType -setup {
.c delete all
+ imageCleanup
+} -body {
+ image create test foo -variable x
+ image create test foo2 -variable y
+ image create test xyzzy -variable z
.c create image 50 100 -image xyzzy -tags i1
update
- set names [lsort [image names]]
+ set names [lsort [imageNames]]
image delete xyzzy
set z {}
- set names2 [lsort [image names]]
+ set names2 [lsort [imageNames]]
.c delete i1
update
- list $names $names2 $z [lsort [image names]]
-} {{foo foo2 xyzzy} {foo foo2} {} {foo foo2}}
-test canvImg-5.2 {DeleteImage procedure (don't delete non-existent image)} {
+ list $names $names2 $z [lsort [imageNames]]
+} -cleanup {
+ imageCleanup
+ .c delete all
+} -result {{foo foo2 xyzzy} {foo foo2} {} {foo foo2}}
+test canvImg-5.2 {DeleteImage procedure (don't delete non-existent image)} -body {
.c delete all
.c create image 50 100 -tags i1
update
.c delete i1
update
-} {}
+} -result {}
+
-test canvImg-6.1 {ComputeImageBbox procedure} testImageType {
+test canvImg-6.1 {ComputeImageBbox procedure} -constraints testImageType -setup {
+ image create test foo
.c delete all
+} -body {
.c create image 15.51 17.51 -image foo -tags i1 -anchor nw
.c bbox i1
-} {16 18 46 33}
-test canvImg-6.2 {ComputeImageBbox procedure} testImageType {
+} -cleanup {
.c delete all
+ imageCleanup
+} -result {16 18 46 33}
+test canvImg-6.2 {ComputeImageBbox procedure} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
.c create image 15.49 17.49 -image foo -tags i1 -anchor nw
.c bbox i1
-} {15 17 45 32}
-test canvImg-6.3 {ComputeImageBbox procedure} {
+} -cleanup {
+ .c delete all
+ imageCleanup
+} -result {15 17 45 32}
+test canvImg-6.3 {ComputeImageBbox procedure} -setup {
.c delete all
+} -body {
.c create image 20 30 -tags i1 -anchor nw
.c bbox i1
-} {}
-test canvImg-6.4 {ComputeImageBbox procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-6.4 {ComputeImageBbox procedure} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor nw
.c bbox i1
-} {20 30 50 45}
-test canvImg-6.5 {ComputeImageBbox procedure} testImageType {
+} -cleanup {
+ .c delete all
+ imageCleanup
+} -result {20 30 50 45}
+test canvImg-6.5 {ComputeImageBbox procedure} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor n
.c bbox i1
-} {5 30 35 45}
-test canvImg-6.6 {ComputeImageBbox procedure} testImageType {
+} -cleanup {
+ .c delete all
+ imageCleanup
+} -result {5 30 35 45}
+test canvImg-6.6 {ComputeImageBbox procedure} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor ne
.c bbox i1
-} {-10 30 20 45}
-test canvImg-6.7 {ComputeImageBbox procedure} testImageType {
+} -cleanup {
+ .c delete all
+ imageCleanup
+} -result {-10 30 20 45}
+test canvImg-6.7 {ComputeImageBbox procedure} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor e
.c bbox i1
-} {-10 23 20 38}
-test canvImg-6.8 {ComputeImageBbox procedure} testImageType {
+} -cleanup {
+ .c delete all
+ imageCleanup
+} -result {-10 23 20 38}
+test canvImg-6.8 {ComputeImageBbox procedure} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor se
.c bbox i1
-} {-10 15 20 30}
-test canvImg-6.9 {ComputeImageBbox procedure} testImageType {
+} -cleanup {
+ .c delete all
+ imageCleanup
+} -result {-10 15 20 30}
+test canvImg-6.9 {ComputeImageBbox procedure} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor s
.c bbox i1
-} {5 15 35 30}
-test canvImg-6.10 {ComputeImageBbox procedure} testImageType {
+} -cleanup {
+ .c delete all
+ imageCleanup
+} -result {5 15 35 30}
+test canvImg-6.10 {ComputeImageBbox procedure} -constraints {
+ testImageType
+} -setup {
+ image create test foo
+ .c delete all
+} -body {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor sw
.c bbox i1
-} {20 15 50 30}
-test canvImg-6.11 {ComputeImageBbox procedure} testImageType {
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {20 15 50 30}
+test canvImg-6.11 {ComputeImageBbox procedure} -constraints {
+ testImageType
+} -setup {
+ image create test foo
+ .c delete all
+} -body {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor w
.c bbox i1
-} {20 23 50 38}
-test canvImg-6.12 {ComputeImageBbox procedure} testImageType {
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {20 23 50 38}
+test canvImg-6.12 {ComputeImageBbox procedure} -constraints {
+ testImageType
+} -setup {
+ image create test foo
+ .c delete all
+} -body {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor center
.c bbox i1
-} {5 23 35 38}
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {5 23 35 38}
# The following test is non-portable because of differences in
# coordinate rounding on some machines (does 0.5 round up?).
-test canvImg-7.1 {DisplayImage procedure} {nonPortable testImageType} {
+test canvImg-7.1 {DisplayImage procedure} -constraints {
+ nonPortable testImageType
+} -setup {
.c delete all
+} -body {
+ image create test foo -variable x
.c create image 50 100 -image foo -tags i1 -anchor nw
update
set x {}
.c create rect 55 110 65 115 -width 1 -outline black -fill white
update
set x
-} {{foo display 4 9 12 6 30 30}}
-test canvImg-7.2 {DisplayImage procedure, no image} {
+} -result {{foo display 4 9 12 6 30 30}}
+test canvImg-7.2 {DisplayImage procedure, no image} -body {
.c delete all
.c create image 50 100 -tags i1
update
.c create rect 55 110 65 115 -width 1 -outline black -fill white
update
-} {}
+} -result {}
-.c delete all
+
+# image used in 8.* test cases
if {[testConstraint testImageType]} {
- .c create image 50 100 -image foo -tags image -anchor nw
+ image create test foo
}
-.c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
-foreach check {
- {canvImg-8.1 {50 70 80 81} {70 90} rect}
- {canvImg-8.2 {50 70 80 79} {70 90} image}
- {canvImg-8.3 {99 70 110 81} {90 90} rect}
- {canvImg-8.4 {101 70 110 79} {90 90} image}
- {canvImg-8.5 {99 100 110 115} {90 110} rect}
- {canvImg-8.6 {101 100 110 115} {90 110} image}
- {canvImg-8.7 {99 134 110 145} {90 125} rect}
- {canvImg-8.8 {101 136 110 145} {90 125} image}
- {canvImg-8.9 {50 134 80 145} {70 125} rect}
- {canvImg-8.10 {50 136 80 145} {70 125} image}
- {canvImg-8.11 {20 134 31 145} {40 125} rect}
- {canvImg-8.12 {20 136 29 145} {40 125} image}
- {canvImg-8.13 {20 100 31 115} {40 110} rect}
- {canvImg-8.14 {20 100 29 115} {40 110} image}
- {canvImg-8.15 {20 70 31 80} {40 90} rect}
- {canvImg-8.16 {20 70 29 79} {40 90} image}
- {canvImg-8.17 {60 70 69 109} {70 110} image}
- {canvImg-8.18 {60 70 71 111} {70 110} rect}
-} {
- lassign $check name rectCoords testPoint result
- test $name {ImageToPoint procedure} testImageType {
- .c coords rect {*}$rectCoords
- .c gettags [.c find closest {*}$testPoint]
- } $result
-}
-
+test canvImg-8.1 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect 50 70 80 81
+ .c gettags [.c find closest 70 90]
+} -cleanup {
+ .c delete all
+} -result {rect}
+test canvImg-8.2 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{50 70 80 79}
+ .c gettags [.c find closest {*}{70 90}]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.3 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{99 70 110 81}
+ .c gettags [.c find closest {*}{90 90}]
+} -cleanup {
+ .c delete all
+} -result {rect}
+test canvImg-8.4 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{101 70 110 79}
+ .c gettags [.c find closest {*}{90 90}]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.5 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{99 100 110 115}
+ .c gettags [.c find closest {*}{90 110}]
+} -cleanup {
+ .c delete all
+} -result {rect}
+test canvImg-8.6 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{101 100 110 115}
+ .c gettags [.c find closest {*}{90 110}]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.7 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{99 134 110 145}
+ .c gettags [.c find closest {*}{90 125}]
+} -cleanup {
+ .c delete all
+} -result {rect}
+test canvImg-8.8 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{101 136 110 145}
+ .c gettags [.c find closest {*}{90 125}]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.9 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{50 134 80 145}
+ .c gettags [.c find closest {*}{70 125}]
+} -cleanup {
+ .c delete all
+} -result {rect}
+test canvImg-8.10 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{50 136 80 145}
+ .c gettags [.c find closest {*}{70 125}]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.11 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{20 134 31 145}
+ .c gettags [.c find closest {*}{40 125}]
+} -cleanup {
+ .c delete all
+} -result {rect}
+test canvImg-8.12 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{20 136 29 145}
+ .c gettags [.c find closest {*}{40 125}]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.13 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{20 100 31 115}
+ .c gettags [.c find closest {*}{40 110}]
+} -cleanup {
+ .c delete all
+} -result {rect}
+test canvImg-8.14 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{20 100 29 115}
+ .c gettags [.c find closest {*}{40 110}]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.15 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{20 70 31 80}
+ .c gettags [.c find closest {*}{40 90}]
+} -cleanup {
+ .c delete all
+} -result {rect}
+test canvImg-8.16 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{20 70 29 79}
+ .c gettags [.c find closest {*}{40 90}]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.17 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{60 70 69 109}
+ .c gettags [.c find closest {*}{70 110}]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.18 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{60 70 71 111}
+ .c gettags [.c find closest {*}{70 110}]
+} -cleanup {
+ .c delete all
+} -result {rect}
.c delete all
-if {[testConstraint testImageType]} {
+
+test canvImg-8.19 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
-}
-test canvImg-8.19 {ImageToArea procedure} testImageType {
.c gettags [.c find overlapping 60 0 70 99]
-} {}
-test canvImg-8.20 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.20 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 60 0 70 99.999]
-} {}
-test canvImg-8.21 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.21 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 60 0 70 101]
-} {image}
-test canvImg-8.22 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.22 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 81 105 120 115]
-} {}
-test canvImg-8.23 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.23 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 80.001 105 120 115]
-} {}
-test canvImg-8.24 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.24 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 79 105 120 115]
-} {image}
-test canvImg-8.25 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.25 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 60 116 70 150]
-} {}
-test canvImg-8.26 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.26 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 60 115.001 70 150]
-} {}
-test canvImg-8.27 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.27 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 60 114 70 150]
-} {image}
-test canvImg-8.28 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.28 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 0 105 49 115]
-} {}
-test canvImg-8.29 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.29 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 0 105 50 114.999]
-} {}
-test canvImg-8.30 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.30 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 0 105 51 115]
-} {image}
-test canvImg-8.31 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.31 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 0 0 49.999 99.999]
-} {}
-test canvImg-8.32 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.32 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 0 0 51 101]
-} {image}
-test canvImg-8.33 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.33 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 80 0 150 100]
-} {}
-test canvImg-8.34 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.34 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 79 0 150 101]
-} {image}
-test canvImg-8.35 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.35 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 80.001 115.001 150 180]
-} {}
-test canvImg-8.36 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.36 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 79 114 150 180]
-} {image}
-test canvImg-8.37 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.37 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 0 115 50 180]
-} {}
-test canvImg-8.38 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.38 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 0 114 51 180]
-} {image}
-test canvImg-8.39 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.39 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find enclosed 0 0 200 200]
-} {image}
-test canvImg-8.40 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.40 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find enclosed 49.999 99.999 80.001 115.001]
-} {image}
-test canvImg-8.41 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.41 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find enclosed 51 100 80 115]
-} {}
-test canvImg-8.42 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.42 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find enclosed 50 101 80 115]
-} {}
-test canvImg-8.43 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.43 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find enclosed 50 100 79 115]
-} {}
-test canvImg-8.44 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.44 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find enclosed 50 100 80 114]
-} {}
+} -cleanup {
+ .c delete all
+} -result {}
+if {[testConstraint testImageType]} {
+ image delete foo
+}
+
-test canvImg-9.1 {DisplayImage procedure} testImageType {
+test canvImg-9.1 {DisplayImage procedure} -constraints testImageType -setup {
.c delete all
+ image create test foo
+} -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c scale image 25 0 2.0 1.5
.c bbox image
-} {75 150 105 165}
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {75 150 105 165}
-test canvImg-10.1 {TranslateImage procedure} testImageType {
+test canvImg-10.1 {TranslateImage procedure} -constraints testImageType -setup {
.c delete all
+} -body {
+ image create test foo -variable x
.c create image 50 100 -image foo -tags image -anchor nw
update
set x {}
foo changed 2 4 6 8 30 15
update
- set x
-} {{foo display 2 4 6 8 30 30}}
+ return $x
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {{foo display 2 4 6 8 30 30}}
-test canvImg-11.1 {TranslateImage procedure} testImageType {
+test canvImg-11.1 {TranslateImage procedure} -constraints testImageType -setup {
.c delete all
+} -body {
+ image create test foo -variable x
.c create image 50 100 -image foo -tags image -anchor nw
update
set x {}
foo changed 2 4 6 8 40 50
update
- set x
-} {{foo display 0 0 40 50 30 30}}
-test canvImg-11.2 {ImageChangedProc procedure} testImageType {
- .c delete all
+ return $x
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {{foo display 0 0 40 50 30 30}}
+test canvImg-11.2 {ImageChangedProc procedure} -constraints {
+ testImageType
+} -setup {
+ .c delete all
+} -body {
image create test foo -variable x
.c create image 50 100 -image foo -tags image -anchor center
update
set x {}
foo changed 0 0 0 0 40 50
.c bbox image
-} {30 75 70 125}
-test canvImg-11.3 {ImageChangedProc procedure} testImageType {
- .c delete all
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {30 75 70 125}
+test canvImg-11.3 {ImageChangedProc procedure} -constraints {
+ testImageType
+} -setup {
+ .c delete all
+} -body {
image create test foo -variable x
+ image create test foo2 -variable y
foo changed 0 0 0 0 40 50
+ foo2 changed 0 0 0 0 80 60
+
.c create image 50 100 -image foo -tags image -anchor nw
.c create image 70 110 -image foo2 -anchor nw
update
set y {}
image create test foo -variable x
update
- set y
-} {{foo2 display 0 0 20 40 50 40}}
+ return $y
+} -cleanup {
+ .c delete all
+ image delete foo foo2
+} -result {{foo2 display 0 0 20 40 50 40}}
# cleanup
+imageFinish
cleanupTests
return
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tests/canvMoveto.test b/tests/canvMoveto.test
new file mode 100644
index 0000000..79761a4
--- /dev/null
+++ b/tests/canvMoveto.test
@@ -0,0 +1,56 @@
+# This file is a Tcl script to test out the canvas "moveto" command. It is
+# derived from canvRect.test.
+#
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 2004 Neil McKay.
+# All rights reserved.
+
+package require tcltest 2.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+canvas .c -width 400 -height 300 -bd 2 -relief sunken
+.c create rectangle 20 20 80 80 -tag {test rect1}
+.c create rectangle 40 40 90 100 -tag {test rect2}
+
+test canvMoveto-1.1 {Bad args handling for "moveto" command} -body {
+ .c moveto test
+} -returnCodes error -result {wrong # args: should be ".c moveto tagOrId x y"}
+test canvMoveto-1.2 {Bad args handling for "moveto" command} -body {
+ .c moveto rect
+} -returnCodes error -result {wrong # args: should be ".c moveto tagOrId x y"}
+test canvMoveto-1.3 {Bad args handling for "moveto" command} -body {
+ .c moveto test 12
+} -returnCodes error -result {wrong # args: should be ".c moveto tagOrId x y"}
+test canvMoveto-1.4 {Bad args handling for "moveto" command} -body {
+ .c moveto test 12 y
+} -returnCodes error -result {bad screen distance "y"}
+test canvMoveto-1.5 {Bad args handling for "moveto" command} -body {
+ .c moveto test 12 20 -anchor
+} -returnCodes error -result {wrong # args: should be ".c moveto tagOrId x y"}
+
+test canvMoveto-2.1 {Canvas "moveto" command coordinates} {
+ .c moveto test 200 150
+ .c bbox test
+} {200 150 272 232}
+test canvMoveto-2.2 {Canvas "moveto" command, blank y coordinate} {
+ .c moveto test 200 150
+ .c moveto test 150 {}
+ .c bbox test
+} {150 150 222 232}
+test canvMoveto-2.3 {Canvas "moveto" command, blank x coordinate} {
+ .c moveto test 200 150
+ .c moveto test {} 200
+ .c bbox test
+} {200 200 272 282}
+
+.c delete withtag all
+
+# cleanup
+cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/canvPs.test b/tests/canvPs.test
index f2df447..c7ba958 100644
--- a/tests/canvPs.test
+++ b/tests/canvPs.test
@@ -6,10 +6,13 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
+imageInit
+# canvas used in 1.* and 2.* test cases
canvas .c -width 400 -height 300 -bd 2 -relief sunken
.c create rectangle 20 20 80 80 -fill red
pack .c
@@ -43,6 +46,7 @@ test canvPs-1.2 {test writing to a file, idempotency} -constraints {
removeFile bar.ps
} -result ok
+
test canvPs-2.1 {test writing to a channel} -constraints {
unixOrPc
} -setup {
@@ -75,7 +79,7 @@ test canvPs-2.2 {test writing to channel, idempotency} -constraints {
close $c2
set status ok
if {[file size $bar] != [file size $foo]} {
- set status broken
+ set status broken
}
set status
} -cleanup {
@@ -97,7 +101,7 @@ test canvPs-2.3 {test writing to channel and file, same output} -constraints {
.c postscript -file $bar
set status ok
if {[file size $foo] != [file size $bar]} {
- set status broken
+ set status broken
}
set status
} -cleanup {
@@ -119,21 +123,22 @@ test canvPs-2.4 {test writing to channel and file, same output} -constraints {
.c postscript -file $bar
set status ok
if {[file size $foo] != [file size $bar]} {
- set status broken
+ set status broken
}
set status
} -cleanup {
removeFile foo.ps
removeFile bar.ps
} -result ok
+destroy .c
+
-test canvPs-3.1 {test ps generation with an embedded window} -setup {
+test canvPs-3.1 {test ps generation with an embedded window} -constraints {
+ notAqua
+} -setup {
set bar [makeFile {} bar.ps]
file delete $bar
-} -constraints {
- notAqua
} -body {
- destroy .c
pack [canvas .c -width 200 -height 200 -background white]
.c create rect 20 20 150 150 -tags rect0 -dash . -width 2
.c create arc 0 50 200 200 -tags arc0 \
@@ -150,13 +155,14 @@ test canvPs-3.1 {test ps generation with an embedded window} -setup {
.c postscript -file $bar
file exists $bar
} -cleanup {
+ destroy .c
+ imageCleanup
removeFile bar.ps
-} -result 1
+} -result {1}
test canvPs-3.2 {test ps generation with an embedded window not mapped} -setup {
set bar [makeFile {} bar.ps]
file delete $bar
} -body {
- destroy .c
pack [canvas .c -width 200 -height 200 -background white]
entry .c.e -background pink -foreground blue -width 14
.c.e insert 0 "we gonna be postscripted"
@@ -164,18 +170,27 @@ test canvPs-3.2 {test ps generation with an embedded window not mapped} -setup {
.c postscript -file $bar
file exists $bar
} -cleanup {
+ destroy .c
removeFile bar.ps
-} -result 1
+} -result {1}
-test canvPs-4.1 {test ps generation with single-point uncolored poly, bug 734498} {} {
- destroy .c
+
+test canvPs-4.1 {test ps generation with single-point uncolored poly, bug 734498} -body {
pack [canvas .c]
.c create poly 10 20 10 20
- catch {.c postscript}
-} 0
+ .c postscript
+} -cleanup {
+ destroy .c
+} -returnCodes ok -match glob -result *
+
# cleanup
unset -nocomplain foo bar
+imageFinish
deleteWindows
cleanupTests
return
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tests/canvRect.test b/tests/canvRect.test
index b6c828e..a2cc51c 100644
--- a/tests/canvRect.test
+++ b/tests/canvRect.test
@@ -6,301 +6,444 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
+# Canvas used in every test case of the whole file
canvas .c -width 400 -height 300 -bd 2 -relief sunken
pack .c
-bind .c <1> {
- puts "button down at (%x,%y)"
-}
update
-set i 1
+# Rectangle used in canvRect-1.* tests
.c create rectangle 20 20 80 80 -tag test
-foreach test {
- {-fill #ff0000 #ff0000
- non-existent {unknown color name "non-existent"}}
- {-outline #123456 #123456
- bad_color {unknown color name "bad_color"}}
- {-stipple gray50 gray50
- bogus {bitmap "bogus" not defined}}
- {-tags {test a b c} {test a b c}
- {} {}}
- {-width 6.0 6.0
- abc {bad screen distance "abc"}}
-} {
- lassign $test name goodValue goodResult badValue badResult
- test canvRect-1.$i "configuration options: good value for $name" {
- .c itemconfigure test $name $goodValue
- list [lindex [.c itemconfigure test $name] 4] [.c itemcget test $name]
- } [list $goodResult $goodResult]
- incr i
- if {$badValue ne ""} {
- test canvRect-1.$i "configuration options: bad value for $name" -body {
- .c itemconfigure test $name $badValue
- } -returnCodes error -result $badResult
- }
- incr i
-}
-test canvRect-1.$i {configuration options} {
+test canvRect-1.1 {configuration options: good value for -fill} -body {
+ .c itemconfigure test -fill #ff0000
+ list [.c itemcget test -fill] [lindex [.c itemconfigure test -fill] 4]
+} -result {{#ff0000} #ff0000}
+test canvRect-1.2 {configuration options: bad value for -fill} -body {
+ .c itemconfigure test -fill non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test canvRect-1.3 {configuration options: good value for -outline} -body {
+ .c itemconfigure test -outline #123456
+ list [.c itemcget test -outline] [lindex [.c itemconfigure test -outline] 4]
+} -result {{#123456} #123456}
+test canvRect-1.4 {configuration options: bad value for -outline} -body {
+ .c itemconfigure test -outline non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test canvRect-1.5 {configuration options: good value for -stipple } -body {
+ .c itemconfigure test -stipple gray50
+ list [.c itemcget test -stipple ] [lindex [.c itemconfigure test -stipple ] 4]
+} -result {gray50 gray50}
+test canvRect-1.6 {configuration options: bad value for -stipple } -body {
+ .c itemconfigure test -stipple bogus
+} -returnCodes error -result {bitmap "bogus" not defined}
+test canvRect-1.7 {configuration options: good value for -tags} -body {
+ .c itemconfigure test -tags {test a b c}
+ list [.c itemcget test -tags] [lindex [.c itemconfigure test -tags] 4]
+} -result {{test a b c} {test a b c}}
+test canvRect-1.8 {configuration options} -body {
.c itemconfigure test -tags {test xyz}
.c itemcget xyz -tags
-} {test xyz}
+} -result {test xyz}
+test canvRect-1.9 {configuration options: good value for -width} -body {
+ .c itemconfigure test -width 6.0
+ list [.c itemcget test -width] [lindex [.c itemconfigure test -width] 4]
+} -result {6.0 6.0}
+test canvRect-1.10 {configuration options: bad value for -width} -body {
+ .c itemconfigure test -width abc
+} -returnCodes error -result {bad screen distance "abc"}
+.c delete withtag all
+
-test canvRect-2.1 {CreateRectOval procedure} {
- list [catch {.c create rect} msg] $msg
-} {1 {wrong # args: should be ".c create rect coords ?arg arg ...?"}}
-test canvRect-2.2 {CreateRectOval procedure} {
- list [catch {.c create oval x y z} msg] $msg
-} {1 {wrong # coordinates: expected 0 or 4, got 3}}
-test canvRect-2.3 {CreateRectOval procedure} {
- list [catch {.c create rectangle x 2 3 4} msg] $msg
-} {1 {bad screen distance "x"}}
-test canvRect-2.4 {CreateRectOval procedure} {
- list [catch {.c create rectangle 1 y 3 4} msg] $msg
-} {1 {bad screen distance "y"}}
-test canvRect-2.5 {CreateRectOval procedure} {
- list [catch {.c create rectangle 1 2 z 4} msg] $msg
-} {1 {bad screen distance "z"}}
-test canvRect-2.6 {CreateRectOval procedure} {
- list [catch {.c create rectangle 1 2 3 q} msg] $msg
-} {1 {bad screen distance "q"}}
-test canvRect-2.7 {CreateRectOval procedure} {
+test canvRect-2.1 {CreateRectOval procedure} -body {
+ .c create rect
+} -returnCodes error -result {wrong # args: should be ".c create rect coords ?arg ...?"}
+test canvRect-2.2 {CreateRectOval procedure} -body {
+ .c create oval x y z
+} -returnCodes error -result {wrong # coordinates: expected 0 or 4, got 3}
+test canvRect-2.3 {CreateRectOval procedure} -body {
+ .c create rectangle x 2 3 4
+} -returnCodes error -result {bad screen distance "x"}
+test canvRect-2.4 {CreateRectOval procedure} -body {
+ .c create rectangle 1 y 3 4
+} -returnCodes error -result {bad screen distance "y"}
+test canvRect-2.5 {CreateRectOval procedure} -body {
+ .c create rectangle 1 2 z 4
+} -returnCodes error -result {bad screen distance "z"}
+test canvRect-2.6 {CreateRectOval procedure} -body {
+ .c create rectangle 1 2 3 q
+} -returnCodes error -result {bad screen distance "q"}
+test canvRect-2.7 {CreateRectOval procedure} -body {
.c create rectangle 1 2 3 4 -tags x
set result {}
foreach element [.c coords x] {
- lappend result [format %.1f $element]
+ lappend result [format %.1f $element]
}
set result
-} {1.0 2.0 3.0 4.0}
-test canvRect-2.8 {CreateRectOval procedure} {
- list [catch {.c create rectangle 1 2 3 4 -gorp foo} msg] $msg
-} {1 {unknown option "-gorp"}}
-
+} -result {1.0 2.0 3.0 4.0}
+test canvRect-2.8 {CreateRectOval procedure} -body {
+ .c create rectangle 1 2 3 4 -gorp foo
+} -returnCodes error -result {unknown option "-gorp"}
.c delete withtag all
-.c create rectangle 10 20 30 40 -tags x
-test canvRect-3.1 {RectOvalCoords procedure} {
+
+
+test canvRect-3.1 {RectOvalCoords procedure} -body {
+ .c create rectangle 10 20 30 40 -tags x
set result {}
foreach element [.c coords x] {
- lappend result [format %.1f $element]
+ lappend result [format %.1f $element]
}
- set result
-} {10.0 20.0 30.0 40.0}
-test canvRect-3.2 {RectOvalCoords procedure} {
- list [catch {.c coords x a 2 3 4} msg] $msg
-} {1 {bad screen distance "a"}}
-test canvRect-3.3 {RectOvalCoords procedure} {
- list [catch {.c coords x 1 b 3 4} msg] $msg
-} {1 {bad screen distance "b"}}
-test canvRect-3.4 {RectOvalCoords procedure} {
- list [catch {.c coords x 1 2 c 4} msg] $msg
-} {1 {bad screen distance "c"}}
-test canvRect-3.5 {RectOvalCoords procedure} {
- list [catch {.c coords x 1 2 3 d} msg] $msg
-} {1 {bad screen distance "d"}}
-test canvRect-3.6 {RectOvalCoords procedure} {nonPortable} {
+ return $result
+} -cleanup {
+ .c delete withtag all
+} -result {10.0 20.0 30.0 40.0}
+test canvRect-3.2 {RectOvalCoords procedure} -body {
+ .c create rectangle 10 20 30 40 -tags x
+ .c coords x a 2 3 4
+} -cleanup {
+ .c delete withtag all
+} -returnCodes error -result {bad screen distance "a"}
+test canvRect-3.3 {RectOvalCoords procedure} -body {
+ .c create rectangle 10 20 30 40 -tags x
+ .c coords x 1 b 3 4
+} -cleanup {
+ .c delete withtag all
+} -returnCodes error -result {bad screen distance "b"}
+test canvRect-3.4 {RectOvalCoords procedure} -body {
+ .c create rectangle 10 20 30 40 -tags x
+ .c coords x 1 2 c 4
+} -cleanup {
+ .c delete withtag all
+} -returnCodes error -result {bad screen distance "c"}
+test canvRect-3.5 {RectOvalCoords procedure} -body {
+ .c create rectangle 10 20 30 40 -tags x
+ .c coords x 1 2 3 d
+} -cleanup {
+ .c delete withtag all
+} -returnCodes error -result {bad screen distance "d"}
+test canvRect-3.6 {RectOvalCoords procedure} -constraints {
+ nonPortable
+} -body {
+ .c create rectangle 10 20 30 40 -tags x
# Non-portable due to rounding differences.
.c coords x 10 25 15 40
.c bbox x
-} {9 24 16 41}
-test canvRect-3.7 {RectOvalCoords procedure} {
- list [catch {.c coords x 1 2 3 4 5} msg] $msg
-} {1 {wrong # coordinates: expected 0 or 4, got 5}}
+} -cleanup {
+ .c delete withtag all
+} -result {9 24 16 41}
+test canvRect-3.7 {RectOvalCoords procedure} -body {
+ .c create rectangle 10 20 30 40 -tags x
+ .c coords x 1 2 3 4 5
+} -cleanup {
+ .c delete withtag all
+} -returnCodes error -result {wrong # coordinates: expected 0 or 4, got 5}
-.c delete withtag all
-.c create rectangle 10 20 30 40 -tags x -width 1
-test canvRect-4.1 {ConfigureRectOval procedure} {
- list [catch {.c itemconfigure x -width abc} msg] $msg \
- [.c itemcget x -width]
-} {1 {bad screen distance "abc"} 1.0}
-test canvRect-4.2 {ConfigureRectOval procedure} {
- list [catch {.c itemconfigure x -width -5} msg] $msg
-} {1 {bad screen distance "-5"}}
-test canvRect-4.3 {ConfigureRectOval procedure} {nonPortable} {
- # Non-portable due to rounding differences.
+
+test canvRect-4.1 {ConfigureRectOval procedure} -body {
+ .c create rectangle 10 20 30 40 -tags x -width 1
+ .c itemconfigure x -width abc
+} -cleanup {
+ .c delete withtag all
+} -returnCodes error -result {bad screen distance "abc"}
+test canvRect-4.2 {ConfigureRectOval procedure} -body {
+ .c create rectangle 10 20 30 40 -tags x -width 1
+ catch {.c itemconfigure x -width abc}
+ .c itemcget x -width
+} -cleanup {
+ .c delete withtag all
+} -result {1.0}
+test canvRect-4.3 {ConfigureRectOval procedure} -body {
+ .c create rectangle 10 20 30 40 -tags x -width 1
+ .c itemconfigure x -width -5
+} -cleanup {
+ .c delete withtag all
+} -returnCodes error -result {bad screen distance "-5"}
+test canvRect-4.4 {ConfigureRectOval procedure} -constraints nonPortable -body {
+ # Non-portable due to rounding differences
+ .c create rectangle 10 20 30 40 -tags x -width 1
.c itemconfigure x -width 10
.c bbox x
-} {5 15 35 45}
+} -cleanup {
+ .c delete withtag all
+} -result {5 15 35 45}
+
# I can't come up with any good tests for DeleteRectOval.
-.c delete withtag all
-.c create rectangle 10 20 30 40 -tags x -width 1 -outline {}
-test canvRect-5.1 {ComputeRectOvalBbox procedure} {nonPortable} {
+test canvRect-5.1 {ComputeRectOvalBbox procedure} -constraints nonPortable -body {
# Non-portable due to rounding differences:
+ .c create rectangle 10 20 30 40 -tags x -width 1 -outline {}
.c coords x 20 15 10 5
.c bbox x
-} {10 5 20 15}
-test canvRect-5.2 {ComputeRectOvalBbox procedure} {nonPortable} {
+} -cleanup {
+ .c delete withtag all
+} -result {10 5 20 15}
+test canvRect-5.2 {ComputeRectOvalBbox procedure} -constraints nonPortable -body {
# Non-portable due to rounding differences:
+ .c create rectangle 10 20 30 40 -tags x -width 1 -outline {}
.c coords x 10 20 30 10
.c itemconfigure x -width 1 -outline red
.c bbox x
-} {9 9 31 21}
-test canvRect-5.3 {ComputeRectOvalBbox procedure} {nonPortable} {
+} -cleanup {
+ .c delete withtag all
+} -result {9 9 31 21}
+test canvRect-5.3 {ComputeRectOvalBbox procedure} -constraints nonPortable -body {
# Non-portable due to rounding differences:
+ .c create rectangle 10 20 30 40 -tags x -width 1 -outline {}
.c coords x 10 20 30 10
.c itemconfigure x -width 2 -outline red
.c bbox x
-} {9 9 31 21}
-test canvRect-5.4 {ComputeRectOvalBbox procedure} {nonPortable} {
+} -cleanup {
+ .c delete withtag all
+} -result {9 9 31 21}
+test canvRect-5.4 {ComputeRectOvalBbox procedure} -constraints nonPortable -body {
# Non-portable due to rounding differences:
+ .c create rectangle 10 20 30 40 -tags x -width 1 -outline {}
.c coords x 10 20 30 10
.c itemconfigure x -width 3 -outline red
.c bbox x
-} {8 8 32 22}
+} -cleanup {
+ .c delete withtag all
+} -result {8 8 32 22}
# I can't come up with any good tests for DisplayRectOval.
-.c delete withtag all
-set x [.c create rectangle 10 20 30 35 -tags x -fill green]
-set y [.c create rectangle 15 25 25 30 -tags y -fill red]
-test canvRect-6.1 {RectToPoint procedure} {
+test canvRect-6.1 {RectToPoint procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -tags x -fill green]
+ set yId [.c create rectangle 15 25 25 30 -tags y -fill red]
.c itemconfigure y -outline {}
- list [.c find closest 14.9 28] [.c find closest 15.1 28] \
- [.c find closest 24.9 28] [.c find closest 25.1 28]
-} "$x $y $y $x"
-test canvRect-6.2 {RectToPoint procedure} {
+ list [expr {[.c find closest 14.9 28] eq $xId}] \
+ [expr {[.c find closest 15.1 28] eq $yId}] \
+ [expr {[.c find closest 24.9 28] eq $yId}] \
+ [expr {[.c find closest 25.1 28] eq $xId}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1}
+test canvRect-6.2 {RectToPoint procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -tags x -fill green]
+ set yId [.c create rectangle 15 25 25 30 -tags y -fill red]
.c itemconfigure y -outline {}
- list [.c find closest 20 24.9] [.c find closest 20 25.1] \
- [.c find closest 20 29.9] [.c find closest 20 30.1]
-} "$x $y $y $x"
-test canvRect-6.3 {RectToPoint procedure} {
+ list [expr {[.c find closest 20 24.9] eq $xId}] \
+ [expr {[.c find closest 20 25.1] eq $yId}] \
+ [expr {[.c find closest 20 29.9] eq $yId}] \
+ [expr {[.c find closest 20 30.1] eq $xId}]
+
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1}
+test canvRect-6.3 {RectToPoint procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -tags x -fill green]
+ set yId [.c create rectangle 15 25 25 30 -tags y -fill red]
.c itemconfigure y -width 1 -outline black
- list [.c find closest 14.4 28] [.c find closest 14.6 28] \
- [.c find closest 25.4 28] [.c find closest 25.6 28]
-} "$x $y $y $x"
-test canvRect-6.4 {RectToPoint procedure} {
+ list [expr {[.c find closest 14.4 28] eq $xId}] \
+ [expr {[.c find closest 14.6 28] eq $yId}] \
+ [expr {[.c find closest 25.4 28] eq $yId}] \
+ [expr {[.c find closest 25.6 28] eq $xId}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1}
+test canvRect-6.4 {RectToPoint procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -tags x -fill green]
+ set yId [.c create rectangle 15 25 25 30 -tags y -fill red]
.c itemconfigure y -width 1 -outline black
- list [.c find closest 20 24.4] [.c find closest 20 24.6] \
- [.c find closest 20 30.4] [.c find closest 20 30.6]
-} "$x $y $y $x"
-.c itemconfigure x -fill {} -outline black -width 3
-.c itemconfigure y -outline {}
-test canvRect-6.5 {RectToPoint procedure} {
- list [.c find closest 13.2 28] [.c find closest 13.3 28] \
- [.c find closest 26.7 28] [.c find closest 26.8 28]
-} "$x $y $y $x"
-test canvRect-6.6 {RectToPoint procedure} {
- list [.c find closest 20 23.2] [.c find closest 20 23.3] \
- [.c find closest 20 31.7] [.c find closest 20 31.8]
-} "$x $y $y $x"
-.c delete withtag all
-set x [.c create rectangle 10 20 30 40 -outline {} -fill black]
-set y [.c create rectangle 40 40 50 50 -outline {} -fill black]
-test canvRect-6.7 {RectToPoint procedure} {
- list [.c find closest 35 35] [.c find closest 36 36] \
- [.c find closest 37 37] [.c find closest 38 38]
-} "$x $y $y $y"
+ list [expr {[.c find closest 20 24.4] eq $xId}] \
+ [expr {[.c find closest 20 24.6] eq $yId}] \
+ [expr {[.c find closest 20 30.4] eq $yId}] \
+ [expr {[.c find closest 20 30.6] eq $xId}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1}
-.c delete withtag all
-set x [.c create rectangle 10 20 30 35 -fill green -outline {}]
-set y [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
-set z [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
-test canvRect-7.1 {RectToArea procedure} {
- list [.c find overlapping 20 50 38 60] \
- [.c find overlapping 20 50 39 60] \
- [.c find overlapping 20 50 70 60] \
- [.c find overlapping 61 50 70 60] \
- [.c find overlapping 62 50 70 60]
-} "{} $y $y $y {}"
-test canvRect-7.2 {RectToArea procedure} {
- list [.c find overlapping 45 20 55 43] \
- [.c find overlapping 45 20 55 44] \
- [.c find overlapping 45 20 55 80] \
- [.c find overlapping 45 71 55 80] \
- [.c find overlapping 45 72 55 80]
-} "{} $y $y $y {}"
-test canvRect-7.3 {RectToArea procedure} {
- list [.c find overlapping 5 25 9.9 30] [.c find overlapping 5 25 10.1 30]
-} "{} $x"
-test canvRect-7.4 {RectToArea procedure} {
- list [.c find overlapping 102 152 118 168] \
- [.c find overlapping 101 152 118 168] \
- [.c find overlapping 102 151 118 168] \
- [.c find overlapping 102 152 119 168] \
- [.c find overlapping 102 152 118 169]
-} "{} $z $z $z $z"
-test canvRect-7.5 {RectToArea procedure} {
- list [.c find enclosed 20 40 38 80] \
- [.c find enclosed 20 40 39 80] \
- [.c find enclosed 20 40 70 80] \
- [.c find enclosed 61 40 70 80] \
- [.c find enclosed 62 40 70 80]
-} "{} {} $y {} {}"
-test canvRect-7.6 {RectToArea procedure} {
- list [.c find enclosed 20 20 65 43] \
- [.c find enclosed 20 20 65 44] \
- [.c find enclosed 20 20 65 80] \
- [.c find enclosed 20 71 65 80] \
- [.c find enclosed 20 72 65 80]
-} "{} {} $y {} {}"
+test canvRect-6.5 {RectToPoint procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -tags x -fill green]
+ set yId [.c create rectangle 15 25 25 30 -tags y -fill red]
+ .c itemconfigure x -fill {} -outline black -width 3
+ .c itemconfigure y -outline {}
+ list [expr {[.c find closest 13.2 28] eq $xId}] \
+ [expr {[.c find closest 13.3 28] eq $yId}] \
+ [expr {[.c find closest 26.7 28] eq $yId}] \
+ [expr {[.c find closest 26.8 28] eq $xId}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1}
+test canvRect-6.6 {RectToPoint procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -tags x -fill green]
+ set yId [.c create rectangle 15 25 25 30 -tags y -fill red]
+ .c itemconfigure x -fill {} -outline black -width 3
+ .c itemconfigure y -outline {}
+ list [expr {[.c find closest 20 23.2] eq $xId}] \
+ [expr {[.c find closest 20 23.3] eq $yId}] \
+ [expr {[.c find closest 20 31.7] eq $yId}] \
+ [expr {[.c find closest 20 31.8] eq $xId}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1}
+
+test canvRect-6.7 {RectToPoint procedure} -body {
+ set xId [.c create rectangle 10 20 30 40 -outline {} -fill black]
+ set yId [.c create rectangle 40 40 50 50 -outline {} -fill black]
+ list [expr {[.c find closest 35 35] eq $xId}] \
+ [expr {[.c find closest 36 36] eq $yId}] \
+ [expr {[.c find closest 37 37] eq $yId}] \
+ [expr {[.c find closest 38 38] eq $yId}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1}
-.c delete withtag all
-set x [.c create oval 50 100 200 150 -fill green -outline {}]
-set y [.c create oval 50 100 200 150 -fill red -outline black -width 3]
-set z [.c create oval 50 100 200 150 -fill {} -outline black -width 3]
-test canvRect-8.1 {OvalToArea procedure} {
- list [.c find overlapping 20 120 48 130] \
- [.c find overlapping 20 120 49 130] \
- [.c find overlapping 20 120 50.2 130] \
- [.c find overlapping 20 120 300 130] \
- [.c find overlapping 60 120 190 130] \
- [.c find overlapping 199.9 120 300 130] \
- [.c find overlapping 201 120 300 130] \
- [.c find overlapping 202 120 300 130]
-} "{} {$y $z} {$x $y $z} {$x $y $z} {$x $y} {$x $y $z} {$y $z} {}"
-test canvRect-8.2 {OvalToArea procedure} {
- list [.c find overlapping 100 50 150 98] \
- [.c find overlapping 100 50 150 99] \
- [.c find overlapping 100 50 150 100.1] \
- [.c find overlapping 100 50 150 200] \
- [.c find overlapping 100 110 150 140] \
- [.c find overlapping 100 149.9 150 200] \
- [.c find overlapping 100 151 150 200] \
- [.c find overlapping 100 152 150 200]
-} "{} {$y $z} {$x $y $z} {$x $y $z} {$x $y} {$x $y $z} {$y $z} {}"
-test canvRect-8.3 {OvalToArea procedure} {
- list [.c find overlapping 176 104 177 105] \
- [.c find overlapping 187 116 188 117] \
- [.c find overlapping 192 142 193 143] \
- [.c find overlapping 180 138 181 139] \
- [.c find overlapping 61 142 62 143] \
- [.c find overlapping 65 137 66 136] \
- [.c find overlapping 62 108 63 109] \
- [.c find overlapping 68 115 69 116]
-} "{} {$x $y} {} {$x $y} {} {$x $y} {} {$x $y}"
-test canvRect-9.1 {ScaleRectOval procedure} {
+test canvRect-7.1 {RectToArea procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -fill green -outline {}]
+ set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
+ set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
+ list [expr {[.c find overlapping 20 50 38 60] eq {}}] \
+ [expr {[.c find overlapping 20 50 39 60] eq $yId}] \
+ [expr {[.c find overlapping 20 50 70 60] eq $yId}] \
+ [expr {[.c find overlapping 61 50 70 60] eq $yId}] \
+ [expr {[.c find overlapping 62 50 70 60] eq {}}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1 1}
+test canvRect-7.2 {RectToArea procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -fill green -outline {}]
+ set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
+ set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
+ list [expr {[.c find overlapping 45 20 55 43] eq {}}] \
+ [expr {[.c find overlapping 45 20 55 44] eq $yId}] \
+ [expr {[.c find overlapping 45 20 55 80] eq $yId}] \
+ [expr {[.c find overlapping 45 71 55 80] eq $yId}] \
+ [expr {[.c find overlapping 45 72 55 80] eq {}}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1 1}
+test canvRect-7.3 {RectToArea procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -fill green -outline {}]
+ set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
+ set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
+ list [expr {[.c find overlapping 5 25 9.9 30] eq {}}] \
+ [expr {[.c find overlapping 5 25 10.1 30] eq $xId}]
+} -cleanup {
+ .c delete all
+} -result {1 1}
+test canvRect-7.4 {RectToArea procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -fill green -outline {}]
+ set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
+ set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
+ list [expr {[.c find overlapping 102 152 118 168] eq {}}]\
+ [expr {[.c find overlapping 101 152 118 168] eq $zId}] \
+ [expr {[.c find overlapping 102 151 118 168] eq $zId}] \
+ [expr {[.c find overlapping 102 152 119 168] eq $zId}] \
+ [expr {[.c find overlapping 102 152 118 169] eq $zId}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1 1}
+test canvRect-7.5 {RectToArea procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -fill green -outline {}]
+ set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
+ set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
+ list [expr {[.c find enclosed 20 40 38 80] eq {}}] \
+ [expr {[.c find enclosed 20 40 39 80] eq {}}] \
+ [expr {[.c find enclosed 20 40 70 80] eq $yId}] \
+ [expr {[.c find enclosed 61 40 70 80] eq {}}] \
+ [expr {[.c find enclosed 62 40 70 80] eq {}}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1 1}
+test canvRect-7.6 {RectToArea procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -fill green -outline {}]
+ set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
+ set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
+ list [expr {[.c find enclosed 20 20 65 43] eq {}}] \
+ [expr {[.c find enclosed 20 20 65 44] eq {}}] \
+ [expr {[.c find enclosed 20 20 65 80] eq $yId}] \
+ [expr {[.c find enclosed 20 71 65 80] eq {}}] \
+ [expr {[.c find enclosed 20 72 65 80] eq {}}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1 1}
+
+
+test canvRect-8.1 {OvalToArea procedure} -body {
+ set xId [.c create oval 50 100 200 150 -fill green -outline {}]
+ set yId [.c create oval 50 100 200 150 -fill red -outline black -width 3]
+ set zId [.c create oval 50 100 200 150 -fill {} -outline black -width 3]
+ list [expr {[.c find overlapping 20 120 48 130] eq {}}] \
+ [expr {[.c find overlapping 20 120 49 130] eq "$yId $zId"}] \
+ [expr {[.c find overlapping 20 120 50.2 130] eq "$xId $yId $zId"}] \
+ [expr {[.c find overlapping 20 120 300 130] eq "$xId $yId $zId"}] \
+ [expr {[.c find overlapping 60 120 190 130] eq "$xId $yId"}] \
+ [expr {[.c find overlapping 199.9 120 300 130] eq "$xId $yId $zId"}] \
+ [expr {[.c find overlapping 201 120 300 130] eq "$yId $zId"}] \
+ [expr {[.c find overlapping 202 120 300 130] eq {}}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1 1 1 1 1}
+test canvRect-8.2 {OvalToArea procedure} -body {
+ set xId [.c create oval 50 100 200 150 -fill green -outline {}]
+ set yId [.c create oval 50 100 200 150 -fill red -outline black -width 3]
+ set zId [.c create oval 50 100 200 150 -fill {} -outline black -width 3]
+ list [expr {[.c find overlapping 100 50 150 98] eq {}}] \
+ [expr {[.c find overlapping 100 50 150 99] eq "$yId $zId"}] \
+ [expr {[.c find overlapping 100 50 150 100.1] eq "$xId $yId $zId"}] \
+ [expr {[.c find overlapping 100 50 150 200] eq "$xId $yId $zId"}] \
+ [expr {[.c find overlapping 100 110 150 140] eq "$xId $yId"}] \
+ [expr {[.c find overlapping 100 149.9 150 200] eq "$xId $yId $zId"}] \
+ [expr {[.c find overlapping 100 151 150 200] eq "$yId $zId"}] \
+ [expr {[.c find overlapping 100 152 150 200] eq {}}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1 1 1 1 1}
+test canvRect-8.3 {OvalToArea procedure} -body {
+ set xId [.c create oval 50 100 200 150 -fill green -outline {}]
+ set yId [.c create oval 50 100 200 150 -fill red -outline black -width 3]
+ set zId [.c create oval 50 100 200 150 -fill {} -outline black -width 3]
+ list [expr {[.c find overlapping 176 104 177 105] eq {}}] \
+ [expr {[.c find overlapping 187 116 188 117] eq "$xId $yId"}] \
+ [expr {[.c find overlapping 192 142 193 143] eq {}}] \
+ [expr {[.c find overlapping 180 138 181 139] eq "$xId $yId"}] \
+ [expr {[.c find overlapping 61 142 62 143] eq {}}] \
+ [expr {[.c find overlapping 65 137 66 136] eq "$xId $yId"}] \
+ [expr {[.c find overlapping 62 108 63 109] eq {}}] \
+ [expr {[.c find overlapping 68 115 69 116] eq "$xId $yId"}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1 1 1 1 1}
+
+
+test canvRect-9.1 {ScaleRectOval procedure} -setup {
.c delete withtag all
+} -body {
.c create rect 100 300 200 350 -tags x
.c scale x 50 100 2 4
- .c coords x
-} {150.0 900.0 350.0 1100.0}
+ format {%.6g %.6g %.6g %.6g} {*}[.c coords x]
+} -result {150 900 350 1100}
-test canvRect-10.1 {TranslateRectOval procedure} {
+test canvRect-10.1 {TranslateRectOval procedure} -setup {
.c delete withtag all
+} -body {
.c create rect 100 300 200 350 -tags x
.c move x 100 -10
- .c coords x
-} {200.0 290.0 300.0 340.0}
+ format {%.6g %.6g %.6g %.6g} {*}[.c coords x]
+} -result {200 290 300 340}
+
-# This test is non-portable because different color information
-# will get generated on different displays (e.g. mono displays
-# vs. color).
-test canvRect-11.1 {RectOvalToPostscript procedure} {nonPortable macCrash} {
+test canvRect-11.1 {RectOvalToPostscript procedure} -constraints {
+ nonPortable macCrash
+} -setup {
+ .c delete withtag all
+} -body {
# Crashes on Mac because the XGetImage() call isn't implemented, causing a
# dereference of NULL.
-
+ # This test is non-portable because different color information
+ # will get generated on different displays (e.g. mono displays
+ # vs. color).
.c configure -bd 0 -highlightthickness 0
- .c delete withtag all
.c create rect 50 60 90 80 -fill black -stipple gray50 -outline {}
.c create oval 100 150 200 200 -fill {} -outline #ff0000 -width 5
update
set x [.c postscript]
string range $x [string first "-200 -150 translate" $x] end
-} {-200 -150 translate
+} -result {-200 -150 translate
0 300 moveto 400 300 lineto 400 0 lineto 0 0 lineto closepath clip newpath
gsave
50 240 moveto 40 0 rlineto 0 -20 rlineto -40 0 rlineto closepath
@@ -326,3 +469,7 @@ end
# cleanup
cleanupTests
return
+
+
+
+
diff --git a/tests/canvText.test b/tests/canvText.test
index 070011b..f0c677f 100644
--- a/tests/canvText.test
+++ b/tests/canvText.test
@@ -6,134 +6,220 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
+# Canvas used in 1.* - 17.* tests
canvas .c -width 400 -height 300 -bd 2 -relief sunken
pack .c
update
-set i 1
+# Item used in 1.* tests
.c create text 20 20 -tag test
-
-set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
-set ay [font metrics $font -linespace]
-set ax [font measure $font 0]
-
-
-foreach test {
- {-anchor nw nw xyz {bad anchor position "xyz": must be n, ne, e, se, s, sw, w, nw, or center}}
- {-fill #ff0000 #ff0000 xyz {unknown color name "xyz"}}
- {-fill {} {} {} {}}
- {-font {Times 40} {Times 40} {} {font "" doesn't exist}}
- {-justify left left xyz {bad justification "xyz": must be left, right, or center}}
- {-stipple gray50 gray50 xyz {bitmap "xyz" not defined}}
- {-tags {test a b c} {test a b c} {} {}}
- {-text xyz xyz {} {}}
- {-underline 0 0 xyz {expected integer but got "xyz"}}
- {-width 6 6 xyz {bad screen distance "xyz"}}
-} {
- lassign $test name goodValue goodResult badValue badResult
- test canvText-1.$i "configuration options: good value for $name" {
- .c itemconfigure test $name $goodValue
- list [lindex [.c itemconfigure test $name] 4] [.c itemcget test $name]
- } [list $goodResult $goodResult]
- incr i
- if {$badValue ne ""} {
- test canvText-1.$i "configuration options: bad value for $name" -body {
- .c itemconfigure test $name $badValue
- } -returnCodes error -result $badResult
- }
- incr i
-}
-test canvText-1.$i {configuration options} {
- .c itemconfigure test -tags {test xyz}
- .c itemcget xyz -tags
-} {test xyz}
-
+test canvText-1.1 {configuration options: good value for "anchor"} -body {
+ .c itemconfigure test -anchor nw
+ list [lindex [.c itemconfigure test -anchor] 4] [.c itemcget test -anchor]
+} -result {nw nw}
+test canvasText-1.2 {configuration options: bad value for "anchor"} -body {
+ .c itemconfigure test -anchor xyz
+} -returnCodes error -result {bad anchor position "xyz": must be n, ne, e, se, s, sw, w, nw, or center}
+test canvText-1.3 {configuration options: good value for "fill"} -body {
+ .c itemconfigure test -fill #ff0000
+ list [lindex [.c itemconfigure test -fill] 4] [.c itemcget test -fill]
+} -result {{#ff0000} #ff0000}
+test canvasText-1.4 {configuration options: bad value for "fill"} -body {
+ .c itemconfigure test -fill xyz
+} -returnCodes error -result {unknown color name "xyz"}
+test canvText-1.5 {configuration options: good value for "fill"} -body {
+ .c itemconfigure test -fill {}
+ list [lindex [.c itemconfigure test -fill] 4] [.c itemcget test -fill]
+} -result {{} {}}
+test canvText-1.6 {configuration options: good value for "font"} -body {
+ .c itemconfigure test -font {Times 40}
+ list [lindex [.c itemconfigure test -font] 4] [.c itemcget test -font]
+} -result {{Times 40} {Times 40}}
+test canvasText-1.7 {configuration options: bad value for "font"} -body {
+ .c itemconfigure test -font {}
+} -returnCodes error -result {font "" doesn't exist}
+test canvText-1.8 {configuration options: good value for "justify"} -body {
+ .c itemconfigure test -justify left
+ list [lindex [.c itemconfigure test -justify] 4] [.c itemcget test -justify]
+} -result {left left}
+test canvasText-1.9 {configuration options: bad value for "justify"} -body {
+ .c itemconfigure test -justify xyz
+} -returnCodes error -result {bad justification "xyz": must be left, right, or center}
+test canvText-1.10 {configuration options: good value for "stipple"} -body {
+ .c itemconfigure test -stipple gray50
+ list [lindex [.c itemconfigure test -stipple] 4] [.c itemcget test -stipple]
+} -result {gray50 gray50}
+test canvasText-1.11 {configuration options: bad value for "stipple"} -body {
+ .c itemconfigure test -stipple xyz
+} -returnCodes error -result {bitmap "xyz" not defined}
+test canvText-1.12 {configuration options: good value for "underline"} -body {
+ .c itemconfigure test -underline 0
+ list [lindex [.c itemconfigure test -underline] 4] [.c itemcget test -underline]
+} -result {0 0}
+test canvasText-1.13 {configuration options: bad value for "underline"} -body {
+ .c itemconfigure test -underline xyz
+} -returnCodes error -result {expected integer but got "xyz"}
+test canvText-1.14 {configuration options: good value for "width"} -body {
+ .c itemconfigure test -width 6
+ list [lindex [.c itemconfigure test -width] 4] [.c itemcget test -width]
+} -result {6 6}
+test canvasText-1.15 {configuration options: bad value for "width"} -body {
+ .c itemconfigure test -width xyz
+} -returnCodes error -result {bad screen distance "xyz"}
+test canvText-1.16 {configuration options: good value for "tags"} -body {
+ .c itemconfigure test -tags {test a b c}
+ list [lindex [.c itemconfigure test -tags] 4] [.c itemcget test -tags]
+} -result {{test a b c} {test a b c}}
+test canvasText-1.17 {configuration options: bad value for "angle"} -body {
+ .c itemconfigure test -angle xyz
+} -returnCodes error -result {expected floating-point number but got "xyz"}
+test canvasText-1.18 {configuration options: good value for "angle"} -body {
+ .c itemconfigure test -angle 32.5
+ list [lindex [.c itemconfigure test -angle] 4] [.c itemcget test -angle]
+} -result {32.5 32.5}
+test canvasText-1.19 {configuration options: bounding of "angle"} -body {
+ .c itemconfigure test -angle 390
+ set result [.c itemcget test -angle]
+ .c itemconfigure test -angle -30
+ lappend result [.c itemcget test -angle]
+ .c itemconfigure test -angle -360
+ lappend result [.c itemcget test -angle]
+} -result {30.0 330.0 0.0}
.c delete test
-.c create text 20 20 -tag test
-test canvText-2.1 {CreateText procedure: args} {
- list [catch {.c create text} msg] $msg
-} {1 {wrong # args: should be ".c create text coords ?arg arg ...?"}}
-test canvText-2.2 {CreateText procedure: args} {
- list [catch {.c create text xyz 0} msg] $msg
-} {1 {bad screen distance "xyz"}}
-test canvText-2.3 {CreateText procedure: args} {
- list [catch {.c create text 0 xyz} msg] $msg
-} {1 {bad screen distance "xyz"}}
-test canvText-2.4 {CreateText procedure: args} {
- list [catch {.c create text 0 0 -xyz xyz} msg] $msg
-} {1 {unknown option "-xyz"}}
-test canvText-2.5 {CreateText procedure} {
+
+test canvText-2.1 {CreateText procedure: args} -body {
+ .c create text
+} -returnCodes {error} -result {wrong # args: should be ".c create text coords ?arg ...?"}
+test canvText-2.2 {CreateText procedure: args} -body {
+ .c create text xyz 0
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {bad screen distance "xyz"}
+test canvText-2.3 {CreateText procedure: args} -body {
+ .c create text 0 xyz
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {bad screen distance "xyz"}
+test canvText-2.4 {CreateText procedure: args} -body {
+ .c create text 0 0 -xyz xyz
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {unknown option "-xyz"}
+test canvText-2.5 {CreateText procedure} -body {
.c create text 0 0 -tags x
- set x [.c coords x]
+ .c coords x
+} -cleanup {
.c delete x
- set x
-} {0.0 0.0}
+} -result {0.0 0.0}
-focus -force .c
-.c focus test
-.c coords test 0 0
-update
-test canvText-3.1 {TextCoords procedure} {
+test canvText-3.1 {TextCoords procedure} -body {
+ .c create text 20 20 -tag test
+ .c coords test 0 0
+ update
.c coords test
-} {0.0 0.0}
-test canvText-3.2 {TextCoords procedure} {
- list [catch {.c coords test xyz 0} msg] $msg
-} {1 {bad screen distance "xyz"}}
-test canvText-3.3 {TextCoords procedure} {
- list [catch {.c coords test 0 xyz} msg] $msg
-} {1 {bad screen distance "xyz"}}
-test canvText-3.4 {TextCoords procedure} {
+} -cleanup {
+ .c delete test
+} -result {0.0 0.0}
+test canvText-3.2 {TextCoords procedure} -setup {
+ .c create text 20 20 -tag test
+} -body {
+ .c coords test xyz 0
+} -cleanup {
+ .c delete test
+} -returnCodes {error} -result {bad screen distance "xyz"}
+test canvText-3.3 {TextCoords procedure} -setup {
+ .c create text 20 20 -tag test
+} -body {
+ .c coords test 0 xyz
+} -cleanup {
+ .c delete test
+} -returnCodes {error} -result {bad screen distance "xyz"}
+test canvText-3.4 {TextCoords procedure} -setup {
+ .c create text 20 20 -tag test
+} -body {
.c coords test 10 10
set result {}
foreach element [.c coords test] {
lappend result [format %.1f $element]
}
- set result
-} {10.0 10.0}
-test canvText-3.5 {TextCoords procedure} {
- list [catch {.c coords test 10} msg] $msg
-} {1 {wrong # coordinates: expected 2, got 1}}
-test canvText-3.6 {TextCoords procedure} {
- list [catch {.c coords test 10 10 10} msg] $msg
-} {1 {wrong # coordinates: expected 0 or 2, got 3}}
-
-test canvText-4.1 {ConfigureText procedure} {
- list [catch {.c itemconfig test -fill xyz} msg] $msg
-} {1 {unknown color name "xyz"}}
-test canvText-4.2 {ConfigureText procedure} {
+ return $result
+} -cleanup {
+ .c delete test
+} -result {10.0 10.0}
+test canvText-3.5 {TextCoords procedure} -setup {
+ .c create text 20 20 -tag test
+} -body {
+ .c coords test 10
+} -cleanup {
+ .c delete test
+} -returnCodes {error} -result {wrong # coordinates: expected 2, got 1}
+test canvText-3.6 {TextCoords procedure} -setup {
+ .c create text 20 20 -tag test
+} -body {
+ .c coords test 10 10 10
+} -cleanup {
+ .c delete test
+} -returnCodes {error} -result {wrong # coordinates: expected 0 or 2, got 3}
+
+
+test canvText-4.1 {ConfigureText procedure} -setup {
+ .c create text 20 20 -tag test
+} -body {
+ .c itemconfig test -fill xyz
+} -cleanup {
+ .c delete test
+} -returnCodes {error} -result {unknown color name "xyz"}
+test canvText-4.2 {ConfigureText procedure} -setup {
+ .c create text 20 20 -tag test
+} -body {
.c itemconfig test -fill blue
.c itemcget test -fill
-} {blue}
-test canvText-4.3 {ConfigureText procedure: construct font gcs} {
+} -cleanup {
+ .c delete test
+} -result {blue}
+test canvText-4.3 {ConfigureText procedure: construct font gcs} -setup {
+ .c create text 20 20 -tag test
+} -body {
.c itemconfig test -font "times 20" -fill black -stipple gray50
list [.c itemcget test -font] [.c itemcget test -fill] [.c itemcget test -stipple]
-} {{times 20} black gray50}
-test canvText-4.4 {ConfigureText procedure: construct cursor gc} {
+} -cleanup {
+ .c delete test
+} -result {{times 20} black gray50}
+test canvText-4.4 {ConfigureText procedure: construct cursor gc} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
.c itemconfig test -text "abcdefg"
.c select from test 2
.c select to test 4
.c icursor test 3
-
# Both black -> cursor becomes white.
.c config -insertbackground black
.c config -selectbackground black
.c itemconfig test -just left
update
-
# Both same color (and not black) -> cursor becomes black.
.c config -insertbackground red
.c config -selectbackground red
.c itemconfig test -just left
update
-} {}
-test canvText-4.5 {ConfigureText procedure: adjust selection} {
+} -cleanup {
+ .c delete test
+} -result {}
+test canvText-4.5 {ConfigureText procedure: adjust selection} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
set x {}
+} -body {
.c itemconfig test -text "abcdefghi"
.c select from test 2
.c select to test 6
@@ -152,89 +238,250 @@ test canvText-4.5 {ConfigureText procedure: adjust selection} {
lappend x [selection get]
.c dchars test 4 end
lappend x [selection get]
-} {cdefg 1 cdefg cd cdef cd}
-test canvText-4.6 {ConfigureText procedure: adjust cursor} {
+} -cleanup {
+ .c delete test
+} -result {cdefg 1 cdefg cd cdef cd}
+test canvText-4.6 {ConfigureText procedure: adjust cursor} -setup {
+ .c create text 20 20 -tag test
+} -body {
.c itemconfig test -text "abcdefghi"
- set x {}
.c icursor test 6
.c dchars test 4 end
.c index test insert
-} {4}
+} -cleanup {
+ .c delete test
+} -result {4}
+
-test canvText-5.1 {ConfigureText procedure: adjust cursor} {
- .c create text 10 10 -tag x -fill blue -font "times 40" -stipple gray50 -text "xyz"
+test canvText-5.1 {ConfigureText procedure: adjust cursor} -body {
+ .c create text 10 10 -tag x -fill blue -font "times 40" -stipple gray50 \
+ -text "xyz"
.c delete x
-} {}
+} -result {}
+
-test canvText-6.1 {ComputeTextBbox procedure} {fonts nonPortable} {
+test canvText-6.1 {ComputeTextBbox procedure} -constraints fonts -setup {
+ .c delete test
+} -body {
+ set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+ set ay [font metrics $font -linespace]
+ set ax [font measure $font 0]
+ .c create text 0 0 -tag test
.c itemconfig test -font $font -text 0
- .c coords test 0 0
- set x {}
- lappend x [.c itemconfig test -anchor n; .c bbox test]
- lappend x [.c itemconfig test -anchor nw; .c bbox test]
- lappend x [.c itemconfig test -anchor w; .c bbox test]
- lappend x [.c itemconfig test -anchor sw; .c bbox test]
- lappend x [.c itemconfig test -anchor s; .c bbox test]
- lappend x [.c itemconfig test -anchor se; .c bbox test]
- lappend x [.c itemconfig test -anchor e; .c bbox test]
- lappend x [.c itemconfig test -anchor ne; .c bbox test]
- lappend x [.c itemconfig test -anchor center; .c bbox test]
-} "{[expr -$ax/2-1] 0 [expr $ax/2+1] $ay}\
-{-1 0 [expr $ax+1] $ay}\
-{-1 [expr -$ay/2] [expr $ax+1] [expr $ay/2]}\
-{-1 -$ay [expr $ax+1] 0}\
-{[expr -$ax/2-1] -$ay [expr $ax/2+1] 0}\
-{[expr -$ax-1] -$ay 1 0}\
-{[expr -$ax-1] [expr -$ay/2] 1 [expr $ay/2]}\
-{[expr -$ax-1] 0 1 $ay}\
-{[expr -$ax/2-1] [expr -$ay/2] [expr $ax/2+1] [expr $ay/2]}"
+ expr {[.c itemconfig test -anchor n; .c bbox test] \
+ eq "[expr -$ax/2-1] 0 [expr $ax/2+1] $ay"}
+} -cleanup {
+ .c delete test
+} -result 1
+test canvText-6.2 {ComputeTextBbox procedure} -constraints fonts -setup {
+ .c delete test
+} -body {
+ set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+ set ay [font metrics $font -linespace]
+ set ax [font measure $font 0]
+ .c create text 0 0 -tag test
+ .c itemconfig test -font $font -text 0
+ expr {[.c itemconfig test -anchor nw; .c bbox test] \
+ eq "-1 0 [expr $ax+1] $ay"}
+} -cleanup {
+ .c delete test
+} -result 1
+test canvText-6.3 {ComputeTextBbox procedure} -constraints fonts -setup {
+ .c delete test
+} -body {
+ set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+ set ay [font metrics $font -linespace]
+ set ax [font measure $font 0]
+ .c create text 0 0 -tag test
+ .c itemconfig test -font $font -text 0
+ expr {[.c itemconfig test -anchor w; .c bbox test] \
+ eq "-1 [expr -$ay/2] [expr $ax+1] [expr $ay/2]"}
+} -cleanup {
+ .c delete test
+} -result 1
+test canvText-6.4 {ComputeTextBbox procedure} -constraints fonts -setup {
+ .c delete test
+} -body {
+ set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+ set ay [font metrics $font -linespace]
+ set ax [font measure $font 0]
+ .c create text 0 0 -tag test
+ .c itemconfig test -font $font -text 0
+ expr {[.c itemconfig test -anchor sw; .c bbox test] \
+ eq "-1 -$ay [expr $ax+1] 0"}
+} -cleanup {
+ .c delete test
+} -result 1
+test canvText-6.5 {ComputeTextBbox procedure} -constraints fonts -setup {
+ .c delete test
+} -body {
+ set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+ set ay [font metrics $font -linespace]
+ set ax [font measure $font 0]
+ .c create text 0 0 -tag test
+ .c itemconfig test -font $font -text 0
+ expr {[.c itemconfig test -anchor s; .c bbox test] \
+ eq "[expr -$ax/2-1] -$ay [expr $ax/2+1] 0"}
+} -cleanup {
+ .c delete test
+} -result 1
+test canvText-6.6 {ComputeTextBbox procedure} -constraints fonts -setup {
+ .c delete test
+} -body {
+ set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+ set ay [font metrics $font -linespace]
+ set ax [font measure $font 0]
+ .c create text 0 0 -tag test
+ .c itemconfig test -font $font -text 0
+ expr {[.c itemconfig test -anchor se; .c bbox test] \
+ eq "[expr -$ax-1] -$ay 1 0"}
+} -cleanup {
+ .c delete test
+} -result 1
+test canvText-6.7 {ComputeTextBbox procedure} -constraints fonts -setup {
+ .c delete test
+} -body {
+ set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+ set ay [font metrics $font -linespace]
+ set ax [font measure $font 0]
+ .c create text 0 0 -tag test
+ .c itemconfig test -font $font -text 0
+ expr {[.c itemconfig test -anchor e; .c bbox test]\
+ eq "[expr -$ax-1] [expr -$ay/2] 1 [expr $ay/2]"}
+} -cleanup {
+ .c delete test
+} -result 1
+test canvText-6.8 {ComputeTextBbox procedure} -constraints fonts -setup {
+ .c delete test
+} -body {
+ set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+ set ay [font metrics $font -linespace]
+ set ax [font measure $font 0]
+ .c create text 0 0 -tag test
+ .c itemconfig test -font $font -text 0
+ expr {[.c itemconfig test -anchor ne; .c bbox test] \
+ eq "[expr -$ax-1] 0 1 $ay"}
+} -cleanup {
+ .c delete test
+} -result 1
+test canvText-6.9 {ComputeTextBbox procedure} -constraints fonts -setup {
+ .c delete test
+} -body {
+ set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+ set ay [font metrics $font -linespace]
+ set ax [font measure $font 0]
+ .c create text 0 0 -tag test
+ .c itemconfig test -font $font -text 0
+ expr {[.c itemconfig test -anchor center; .c bbox test] \
+ eq "[expr -$ax/2-1] [expr -$ay/2] [expr $ax/2+1] [expr $ay/2]"}
+} -cleanup {
+ .c delete test
+} -result 1
+
+#.c delete test
+#.c create text 20 20 -tag test
+#focus -force .c
+#.c focus test
focus .c
.c focus test
.c itemconfig test -text "abcd\nefghi\njklmnopq"
-test canvText-7.0 {DisplayText procedure: stippling} {
+test canvText-7.1 {DisplayText procedure: stippling} -body {
+ .c create text 20 20 -tag test
.c itemconfig test -stipple gray50
update
.c itemconfig test -stipple {}
update
-} {}
-test canvText-7.2 {DisplayText procedure: draw selection} {
+} -cleanup {
+ .c delete test
+} -result {}
+test canvText-7.2 {DisplayText procedure: draw selection} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcd\nefghi\njklmnopq"
.c select from test 0
.c select to test end
update
selection get
-} "abcd\nefghi\njklmnopq"
-test canvText-7.3 {DisplayText procedure: selection} {
+} -cleanup {
+ .c delete test
+} -result "abcd\nefghi\njklmnopq"
+test canvText-7.3 {DisplayText procedure: selection} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcd\nefghi\njklmnopq"
.c select from test 0
.c select to test end
update
selection get
-} "abcd\nefghi\njklmnopq"
-test canvText-7.4 {DisplayText procedure: one line selection} {
+} -cleanup {
+ .c delete test
+} -result "abcd\nefghi\njklmnopq"
+test canvText-7.4 {DisplayText procedure: one line selection} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcd\nefghi\njklmnopq"
.c select from test 2
.c select to test 3
update
-} {}
-test canvText-7.5 {DisplayText procedure: multi-line selection} {
+} -cleanup {
+ .c delete test
+} -result {}
+test canvText-7.5 {DisplayText procedure: multi-line selection} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcd\nefghi\njklmnopq"
.c select from test 2
.c select to test 12
update
-} {}
-test canvText-7.6 {DisplayText procedure: draw cursor} {
+} -cleanup {
+ .c delete test
+} -result {}
+test canvText-7.6 {DisplayText procedure: draw cursor} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcd\nefghi\njklmnopq"
.c icursor test 3
update
-} {}
-test canvText-7.7 {DisplayText procedure: selected text different color} {
+} -cleanup {
+ .c delete test
+} -result {}
+test canvText-7.7 {DisplayText procedure: selected text different color} -setup {
+ .c create text 20 20 -tag test
+ .c itemconfig test -text "abcd\nefghi\njklmnopq"
+ focus .c
+ .c focus test
+} -body {
.c config -selectforeground blue
.c itemconfig test -anchor n
update
-} {}
-test canvText-7.8 {DisplayText procedure: not selected} {
+} -cleanup {
+ .c delete test
+} -result {}
+test canvText-7.8 {DisplayText procedure: not selected} -setup {
+ .c create text 20 20 -tag test
+ .c itemconfig test -text "abcd\nefghi\njklmnopq"
+ focus .c
+ .c focus test
+} -body {
.c select clear
update
-} {}
-test canvText-7.9 {DisplayText procedure: select end} {
- catch {destroy .t}
+} -cleanup {
+ .c delete test
+} -result {}
+test canvText-7.9 {DisplayText procedure: select end} -setup {
+ destroy .t
+} -body {
toplevel .t
wm geometry .t +0+0
canvas .t.c
@@ -246,287 +493,398 @@ test canvText-7.9 {DisplayText procedure: select end} {
update
#catch {destroy .t}
update
-} {}
-
-test canvText-8.1 {TextInsert procedure: 0 length insert} {
+} -cleanup {
+ destroy .t
+} -result {}
+
+test canvText-8.1 {TextInsert procedure: 0 length insert} -setup {
+ .c create text 20 20 -tag test
+ .c itemconfig test -text "abcd\nefghi\njklmnopq"
+ focus .c
+ .c focus test
+} -body {
.c insert test end {}
-} {}
-test canvText-8.2 {TextInsert procedure: before beginning/after end} {
+} -cleanup {
+ .c delete test
+} -result {}
+test canvText-8.2 {TextInsert procedure: before beginning/after end} -body {
# Can't test this because GetTextIndex filters out those numbers.
-} {}
-test canvText-8.3 {TextInsert procedure: inserting in a selected item} {
+} -result {}
+test canvText-8.3 {TextInsert procedure: inserting in a selected item} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
.c itemconfig test -text "abcdefg"
.c select from test 2
.c select to test 4
.c insert test 1 "xyz"
.c itemcget test -text
-} {axyzbcdefg}
-test canvText-8.4 {TextInsert procedure: inserting before selection} {
+} -result {axyzbcdefg}
+test canvText-8.4 {TextInsert procedure: inserting before selection} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
.c itemconfig test -text "abcdefg"
.c select from test 2
.c select to test 4
.c insert test 1 "xyz"
list [.c index test sel.first] [.c index test sel.last]
-} {5 7}
-test canvText-8.5 {TextInsert procedure: inserting in selection} {
+} -result {5 7}
+test canvText-8.5 {TextInsert procedure: inserting in selection} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
.c itemconfig test -text "abcdefg"
.c select from test 2
.c select to test 4
.c insert test 3 "xyz"
list [.c index test sel.first] [.c index test sel.last]
-} {2 7}
-test canvText-8.6 {TextInsert procedure: inserting after selection} {
+} -result {2 7}
+test canvText-8.6 {TextInsert procedure: inserting after selection} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
.c itemconfig test -text "abcdefg"
.c select from test 2
.c select to test 4
.c insert test 5 "xyz"
list [.c index test sel.first] [.c index test sel.last]
-} {2 4}
-test canvText-8.7 {TextInsert procedure: inserting in unselected item} {
+} -result {2 4}
+test canvText-8.7 {TextInsert procedure: inserting in unselected item} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
.c itemconfig test -text "abcdefg"
.c select clear
.c insert test 5 "xyz"
.c itemcget test -text
-} {abcdexyzfg}
-test canvText-8.8 {TextInsert procedure: inserting before cursor} {
+} -result {abcdexyzfg}
+test canvText-8.8 {TextInsert procedure: inserting before cursor} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
.c itemconfig test -text "abcdefg"
.c icursor test 3
.c insert test 2 "xyz"
.c index test insert
-} {6}
-test canvText-8.9 {TextInsert procedure: inserting after cursor} {
+} -result {6}
+test canvText-8.9 {TextInsert procedure: inserting after cursor} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
.c itemconfig test -text "abcdefg"
.c icursor test 3
.c insert test 4 "xyz"
.c index test insert
-} {3}
+} -result {3}
-test canvText-9.1 {TextInsert procedure: before beginning/after end} {
+# Item used in 9.* tests
+.c create text 20 20 -tag test
+test canvText-9.1 {TextInsert procedure: before beginning/after end} -body {
# Can't test this because GetTextIndex filters out those numbers.
-} {}
-test canvText-9.2 {TextInsert procedure: start > end} {
+} -result {}
+test canvText-9.2 {TextInsert procedure: start > end} -body {
.c itemconfig test -text "abcdefg"
.c dchars test 4 2
.c itemcget test -text
-} {abcdefg}
-test canvText-9.3 {TextInsert procedure: deleting from a selected item} {
+} -result {abcdefg}
+test canvText-9.3 {TextInsert procedure: deleting from a selected item} -body {
.c itemconfig test -text "abcdefg"
.c select from test 2
.c select to test 4
.c dchars test 3 5
.c itemcget test -text
-} {abcg}
-test canvText-9.4 {TextInsert procedure: deleting before start} {
+} -result {abcg}
+test canvText-9.4 {TextInsert procedure: deleting before start} -body {
.c itemconfig test -text "abcdefghijk"
.c select from test 4
.c select to test 8
.c dchars test 1 1
list [.c index test sel.first] [.c index test sel.last]
-} {3 7}
-test canvText-9.5 {TextInsert procedure: keep start > first char deleted} {
+} -result {3 7}
+test canvText-9.5 {TextInsert procedure: keep start > first char deleted} -body {
.c itemconfig test -text "abcdefghijk"
.c select from test 4
.c select to test 8
.c dchars test 2 6
list [.c index test sel.first] [.c index test sel.last]
-} {2 3}
-test canvText-9.6 {TextInsert procedure: deleting inside selection} {
+} -result {2 3}
+test canvText-9.6 {TextInsert procedure: deleting inside selection} -body {
.c itemconfig test -text "abcdefghijk"
.c select from test 4
.c select to test 8
.c dchars test 6 6
list [.c index test sel.first] [.c index test sel.last]
-} {4 7}
-test canvText-9.7 {TextInsert procedure: keep end > first char deleted} {
+} -result {4 7}
+test canvText-9.7 {TextInsert procedure: keep end > first char deleted} -body {
.c itemconfig test -text "abcdefghijk"
.c select from test 4
.c select to test 8
.c dchars test 6 10
list [.c index test sel.first] [.c index test sel.last]
-} {4 5}
-test canvText-9.8 {TextInsert procedure: selectFirst > selectLast: deselect} {
+} -result {4 5}
+test canvText-9.8 {TextInsert procedure: selectFirst > selectLast: deselect} -body {
.c itemconfig test -text "abcdefghijk"
.c select from test 4
.c select to test 8
.c dchars test 3 10
- list [catch {.c index test sel.first} msg] $msg
-} {1 {selection isn't in item}}
-test canvText-9.9 {TextInsert procedure: selectFirst <= selectLast} {
+ .c index test sel.first
+} -returnCodes {error} -result {selection isn't in item}
+test canvText-9.9 {TextInsert procedure: selectFirst <= selectLast} -body {
.c itemconfig test -text "abcdefghijk"
.c select from test 4
.c select to test 8
.c dchars test 4 7
list [.c index test sel.first] [.c index test sel.last]
-} {4 4}
-test canvText-9.10 {TextInsert procedure: move anchor} {
+} -result {4 4}
+test canvText-9.10 {TextInsert procedure: move anchor} -body {
.c itemconfig test -text "abcdefghijk"
.c select from test 6
.c select to test 8
.c dchars test 2 4
.c select to test 1
list [.c index test sel.first] [.c index test sel.last]
-} {1 2}
-test canvText-9.11 {TextInsert procedure: keep anchor >= first} {
+} -result {1 2}
+test canvText-9.11 {TextInsert procedure: keep anchor >= first} -body {
.c itemconfig test -text "abcdefghijk"
.c select from test 6
.c select to test 8
.c dchars test 5 7
.c select to test 1
list [.c index test sel.first] [.c index test sel.last]
-} {1 4}
-test canvText-9.12 {TextInsert procedure: anchor doesn't move} {
+} -result {1 4}
+test canvText-9.12 {TextInsert procedure: anchor doesn't move} -body {
.c itemconfig test -text "abcdefghijk"
.c select from test 2
.c select to test 5
.c dchars test 6 8
.c select to test 8
list [.c index test sel.first] [.c index test sel.last]
-} {2 8}
-test canvText-9.13 {TextInsert procedure: move cursor} {
+} -result {2 8}
+test canvText-9.13 {TextInsert procedure: move cursor} -body {
.c itemconfig test -text "abcdefghijk"
.c icursor test 6
.c dchars test 2 4
.c index test insert
-} {3}
-test canvText-9.14 {TextInsert procedure: keep cursor >= first} {
+} -result {3}
+test canvText-9.14 {TextInsert procedure: keep cursor >= first} -body {
.c itemconfig test -text "abcdefghijk"
.c icursor test 6
.c dchars test 2 10
.c index test insert
-} {2}
-test canvText-9.15 {TextInsert procedure: cursor doesn't move} {
+} -result {2}
+test canvText-9.15 {TextInsert procedure: cursor doesn't move} -body {
.c itemconfig test -text "abcdefghijk"
.c icursor test 5
.c dchars test 7 9
.c index test insert
-} {5}
+} -result {5}
+.c delete test
-test canvText-10.1 {TextToPoint procedure} {
- .c coords test 0 0
+
+test canvText-10.1 {TextToPoint procedure} -body {
+ .c create text 0 0 -tag test
.c itemconfig test -text 0 -anchor center
.c index test @0,0
-} {0}
+} -cleanup {
+ .c delete test
+} -result {0}
-test canvText-11.1 {TextToArea procedure} {
- .c coords test 0 0
+
+test canvText-11.1 {TextToArea procedure} -setup {
+ .c create text 0 0 -tag test
+ focus .c
+ .c focus test
+} -body {
.c itemconfig test -text 0 -anchor center
- .c find overlapping 0 0 1 1
-} [.c find withtag test]
-test canvText-11.2 {TextToArea procedure} {
- .c coords test 0 0
+ set res1 [.c find overlapping 0 0 1 1]
+ set res2 [.c find withtag test]
+ expr {$res1 eq $res2}
+} -cleanup {
+ .c delete test
+} -result 1
+test canvText-11.2 {TextToArea procedure} -setup {
+ .c create text 0 0 -tag test
+ focus .c
+ .c focus test
+} -body {
.c itemconfig test -text 0 -anchor center
.c find overlapping 1000 1000 1001 1001
-} {}
+} -cleanup {
+ .c delete test
+} -result {}
-test canvText-12.1 {ScaleText procedure} {
- .c coords test 100 100
+
+test canvText-12.1 {ScaleText procedure} -body {
+ .c create text 100 100 -tag test
.c scale all 50 50 2 2
format {%.6g %.6g} {*}[.c coords test]
-} {150 150}
+} -cleanup {
+ .c delete test
+} -result {150 150}
+
-test canvText-13.1 {TranslateText procedure} {
- .c coords test 100 100
+test canvText-13.1 {TranslateText procedure} -body {
+ .c create text 100 100 -tag test
.c move all 10 10
format {%.6g %.6g} {*}[.c coords test]
-} {110 110}
-
-.c itemconfig test -text "abcdefghijklmno" -anchor nw
-.c select from test 5
-.c select to test 8
-.c icursor test 12
-.c coords test 0 0
-test canvText-14.1 {GetTextIndex procedure} {
+} -cleanup {
+ .c delete test
+} -result {110 110}
+
+
+test canvText-14.1 {GetTextIndex procedure} -setup {
+ .c create text 0 0 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcdefghijklmno" -anchor nw
+ .c select from test 5
+ .c select to test 8
+ .c icursor test 12
+ .c coords test 0 0
list [.c index test end] [.c index test insert] \
[.c index test sel.first] [.c index test sel.last] \
[.c index test @0,0] \
[.c index test -1] [.c index test 10] [.c index test 100]
-} {15 12 5 8 0 0 10 15}
-test canvText-14.2 {GetTextIndex procedure: select error} {
+} -cleanup {
+ .c delete test
+} -result {15 12 5 8 0 0 10 15}
+test canvText-14.2 {GetTextIndex procedure: select error} -setup {
+ .c create text 0 0 -tag test
+ focus .c
+ .c focus test
+} -body {
.c select clear
- list [catch {.c index test sel.first} msg] $msg
-} {1 {selection isn't in item}}
-test canvText-14.3 {GetTextIndex procedure: select error} {
+ .c index test sel.first
+} -cleanup {
+ .c delete test
+} -returnCodes {error} -result {selection isn't in item}
+test canvText-14.3 {GetTextIndex procedure: select error} -setup {
+ .c create text 0 0 -tag test
+ focus .c
+ .c focus test
+} -body {
.c select clear
- list [catch {.c index test sel.last} msg] $msg
-} {1 {selection isn't in item}}
-test canvText-14.4 {GetTextIndex procedure: select error} {
+ .c index test sel.last
+} -cleanup {
+ .c delete test
+} -returnCodes {error} -result {selection isn't in item}
+test canvText-14.4 {GetTextIndex procedure: select error} -setup {
+ .c create text 0 0 -tag test
+ focus .c
+ .c focus test
+} -body {
.c select clear
- list [catch {.c index test sel.} msg] $msg
-} {1 {bad index "sel."}}
-test canvText-14.5 {GetTextIndex procedure: bad int or unknown index} {
- list [catch {.c index test xyz} msg] $msg
-} {1 {bad index "xyz"}}
-test canvText-14.6 {select clear errors} -body {
+ .c index test sel.
+} -cleanup {
+ .c delete test
+} -returnCodes {error} -result {bad index "sel."}
+test canvText-14.5 {GetTextIndex procedure: bad int or unknown index} -setup {
+ .c create text 0 0 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c index test xyz
+} -cleanup {
+ .c delete test
+} -returnCodes {error} -result {bad index "xyz"}
+test canvText-14.6 {select clear errors} -setup {
+ .c create text 0 0 -tag test
+} -body {
.c select clear test
+} -cleanup {
+ .c delete test
} -returnCodes error -result "wrong \# args: should be \".c select clear\""
-test canvText-15.1 {SetTextCursor procedure} {
+test canvText-15.1 {SetTextCursor procedure} -setup {
+ .c create text 0 0 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcdefghijklmno" -anchor nw
.c itemconfig -text "abcdefg"
.c icursor test 3
.c index test insert
-} {3}
-
-test canvText-16.1 {GetSelText procedure} {
+} -cleanup {
+ .c delete test
+} -result {3}
+
+test canvText-16.1 {GetSelText procedure} -setup {
+ .c create text 0 0 -tag test
+ focus .c
+ .c focus test
+} -body {
.c itemconfig test -text "abcdefghijklmno" -anchor nw
.c select from test 5
.c select to test 8
selection get
-} {fghi}
+} -cleanup {
+ .c delete test
+} -result {fghi}
-set font {Courier 12 italic}
-set ax [font measure $font 0]
-set ay [font metrics $font -linespace]
-
-test canvText-17.1 {TextToPostscript procedure} {
+test canvText-17.1 {TextToPostscript procedure} -setup {
.c delete all
- .c config -height 300 -highlightthickness 0 -bd 0
- update
- .c create text 100 100 -tags test
- .c itemconfig test -font $font -text "00000000" -width [expr 3*$ax]
- .c itemconfig test -anchor n -fill black
- set x [.c postscript]
- set x [string range $x [string first "/Courier-Oblique" $x] end]
-} "/Courier-Oblique findfont [font actual $font -size] scalefont ISOEncode setfont
+ set result {/Courier-Oblique findfont [font actual $font -size] scalefont ISOEncode setfont
0.000 0.000 0.000 setrgbcolor AdjustColor
-100 200 \[
+0 100 200 \[
\[(000)\]
\[(000)\]
\[(00)\]
-] $ay -0.5 0.0 0 false DrawText
+\] $ay -0.5 0 0 false DrawText
grestore
restore showpage
%%Trailer
end
%%EOF
-"
+}
+} -body {
+ set font {Courier 12 italic}
+ set ax [font measure $font 0]
+ set ay [font metrics $font -linespace]
+ .c config -height 300 -highlightthickness 0 -bd 0
+ update
+ .c create text 100 100 -tags test
+ .c itemconfig test -font $font -text "00000000" -width [expr 3*$ax]
+ .c itemconfig test -anchor n -fill black
+ set x [.c postscript]
+ set x [string range $x [string first "/Courier-Oblique" $x] end]
+ expr {$x eq [subst $result] ? "ok" : $x}
+} -result ok
-test canvText-18.1 {bug fix 2525, find enclosed on text with newlines} {
- catch {destroy .c}
- canvas .c
- pack .c
- .c delete all
+test canvText-18.1 {bug fix 2525, find enclosed on text with newlines} -setup {
+ destroy .c
+} -body {
+ pack [canvas .c]
.c create text 100 100 -text Hello\n -anchor nw
set bbox [.c bbox 1]
set x2 [lindex $bbox 2]
set y2 [lindex $bbox 3]
incr y2
update
- .c find enclosed 99 99 [expr $x2 + $i] [expr $y2 + 1]
-} 1
+ .c find enclosed 99 99 [expr $x2 + 1] [expr $y2 + 1]
+} -cleanup {
+ destroy .c
+} -result 1
-test canvText-19.1 {patch 1006286, leading space caused wrap under Win32} {
- catch {destroy .c}
+test canvText-19.1 {patch 1006286, leading space caused wrap under Win32} -setup {
+ destroy .c
set c [canvas .c -bg black -width 964]
pack $c
$c delete all
- after 1000 "set done 1" ; vwait done
-
+ after 100 "set done 1"; vwait done
+} -body {
set f {Arial 28 bold}
-
set s1 { Yeah-ah-ah-ah-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-Yow}
set s2 { Yeah ah ah ah oh oh oh oh oh oh oh oh oh oh oh oh oh oh oh oh Yow}
-
$c create text 21 18 \
-font $f \
-text $s1 \
@@ -534,8 +892,7 @@ test canvText-19.1 {patch 1006286, leading space caused wrap under Win32} {
-width 922 \
-anchor nw \
-tags tbox1
- eval {$c create rect} [$c bbox tbox1] -outline red
-
+ $c create rect {*}[$c bbox tbox1] -outline red
$c create text 21 160 \
-font $f \
-text $s2 \
@@ -543,32 +900,49 @@ test canvText-19.1 {patch 1006286, leading space caused wrap under Win32} {
-width 922 \
-anchor nw \
-tags tbox2
- eval {$c create rect} [$c bbox tbox2] -outline red
-
- after 1000 "set done 1" ; vwait done
-
+ $c create rect {*}[$c bbox tbox2] -outline red
+ after 500 "set done 1" ; vwait done
set results [list]
-
$c select from tbox2 4
$c select to tbox2 8
lappend results [selection get]
-
$c select from tbox1 4
$c select to tbox1 8
lappend results [selection get]
-
array set metrics [font metrics $f]
set x [expr {21 + [font measure $f " "] \
+ ([font measure {Arial 28 bold} "Y"] / 2)}]
set y1 [expr {18 + ($metrics(-linespace) / 2)}]
set y2 [expr {160 + ($metrics(-linespace) / 2)}]
-
lappend results [$c index tbox1 @$x,$y1]
lappend results [$c index tbox2 @$x,$y2]
+} -cleanup {
+ destroy .c
+} -result {{Yeah } Yeah- 4 4}
- set results
-} {{Yeah } Yeah- 4 4}
-
+test canvText-20.1 {angled text bounding box} -setup {
+ destroy .c
+ canvas .c
+ proc transpose {bbox} {
+ lassign $bbox a b c d
+ list $b $a $d $c
+ }
+} -body {
+ .c create text 2 2 -tag t -anchor center -text 0 -font {Helvetica 24}
+ set bb0 [.c bbox t]
+ .c itemconf t -angle 90
+ set bb1 [.c bbox t]
+ .c itemconf t -angle 180
+ set bb2 [.c bbox t]
+ .c itemconf t -angle 270
+ set bb3 [.c bbox t]
+ list [expr {$bb0 eq $bb2 ? "ok" : "$bb0,$bb2"}] \
+ [expr {$bb1 eq $bb3 ? "ok" : "$bb1,$bb3"}] \
+ [expr {$bb0 eq [transpose $bb1] ? "ok" : "$bb0,$bb1"}] \
+} -cleanup {
+ destroy .c
+ rename transpose {}
+} -result {ok ok ok}
# cleanup
cleanupTests
diff --git a/tests/canvWind.test b/tests/canvWind.test
index 9844ff0..436ee2c 100644
--- a/tests/canvWind.test
+++ b/tests/canvWind.test
@@ -6,12 +6,14 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
-test canvWind-1.1 {DisplayWinItem, windows off-screen vertically} {
- catch {destroy .t}
+test canvWind-1.1 {DisplayWinItem, windows off-screen vertically} -setup {
+ destroy .t
+} -body {
toplevel .t
canvas .t.c -scrollregion {0 0 1000 800} -width 250 -height 200 -bd 2 \
-relief sunken -xscrollincrement 1 -yscrollincrement 1 \
@@ -37,9 +39,13 @@ test canvWind-1.1 {DisplayWinItem, windows off-screen vertically} {
.t.c yview scroll -1 units
update
lappend x [list [winfo ismapped $f] [winfo y $f]]
-} {{1 23} {1 -29} {0 -29} {1 225} {0 225}}
-test canvWind-1.2 {DisplayWinItem, windows off-screen vertically} {
- catch {destroy .t}
+} -cleanup {
+ destroy .t
+} -result {{1 23} {1 -29} {0 -29} {1 225} {0 225}}
+
+test canvWind-1.2 {DisplayWinItem, windows off-screen vertically} -setup {
+ destroy .t
+} -body {
toplevel .t
canvas .t.c -scrollregion {0 0 1000 800} -width 250 -height 200 -bd 2 \
-relief sunken -xscrollincrement 1 -yscrollincrement 1 \
@@ -65,9 +71,13 @@ test canvWind-1.2 {DisplayWinItem, windows off-screen vertically} {
.t.c yview scroll -1 units
update
lappend x [list [winfo ismapped $f] [winfo y $f]]
-} {{1 3} {1 -49} {0 -49} {1 205} {0 205}}
-test canvWind-1.3 {DisplayWinItem, windows off-screen horizontally} {
- catch {destroy .t}
+} -cleanup {
+ destroy .t
+} -result {{1 3} {1 -49} {0 -49} {1 205} {0 205}}
+
+test canvWind-1.3 {DisplayWinItem, windows off-screen horizontally} -setup {
+ destroy .t
+} -body {
toplevel .t
canvas .t.c -scrollregion {0 0 1000 800} -width 250 -height 200 -bd 2 \
-relief sunken -xscrollincrement 1 -yscrollincrement 1 \
@@ -93,9 +103,13 @@ test canvWind-1.3 {DisplayWinItem, windows off-screen horizontally} {
.t.c xview scroll -1 units
update
lappend x [list [winfo ismapped $f] [winfo x $f]]
-} {{1 23} {1 -59} {0 -59} {1 275} {0 275}}
-test canvWind-1.4 {DisplayWinItem, windows off-screen horizontally} {
- catch {destroy .t}
+} -cleanup {
+ destroy .t
+} -result {{1 23} {1 -59} {0 -59} {1 275} {0 275}}
+
+test canvWind-1.4 {DisplayWinItem, windows off-screen horizontally} -setup {
+ destroy .t
+} -body {
toplevel .t
canvas .t.c -scrollregion {0 0 1000 800} -width 250 -height 200 -bd 2 \
-relief sunken -xscrollincrement 1 -yscrollincrement 1 \
@@ -121,8 +135,9 @@ test canvWind-1.4 {DisplayWinItem, windows off-screen horizontally} {
.t.c xview scroll -1 units
update
lappend x [list [winfo ismapped $f] [winfo x $f]]
-} {{1 3} {1 -79} {0 -79} {1 255} {0 255}}
-catch {destroy .t}
+} -cleanup {
+ destroy .t
+} -result {{1 3} {1 -79} {0 -79} {1 255} {0 255}}
# cleanup
cleanupTests
diff --git a/tests/canvas.test b/tests/canvas.test
index 6fea894..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..8f7aa9f 100644
--- a/tests/config.test
+++ b/tests/config.test
@@ -6,7 +6,8 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
@@ -14,436 +15,1038 @@ proc killTables {} {
# Note: it's important to delete chain2 before chain1, because
# chain2 depends on chain1. If chain1 is deleted first, the
# delete of chain2 will crash.
-
+ deleteWindows
foreach t {alltypes chain2 chain1 configerror internal new notenoughparams
twowindows} {
- while {[testobjconfig info $t] != ""} {
- testobjconfig delete $t
- }
+ while {[testobjconfig info $t] != ""} {
+ testobjconfig delete $t
+ }
}
}
+
+option clear
+deleteWindows
if {[testConstraint testobjconfig]} {
killTables
}
-test config-1.1 {Tk_CreateOptionTable - reference counts} testobjconfig {
- deleteWindows
- killTables
+test config-1.1 {Tk_CreateOptionTable - reference counts} -constraints {
+ testobjconfig
+} -body {
set x {}
testobjconfig alltypes .a
lappend x [testobjconfig info alltypes]
testobjconfig alltypes .b
lappend x [testobjconfig info alltypes]
- deleteWindows
set x
-} {{1 16 -boolean} {2 16 -boolean}}
-test config-1.2 {Tk_CreateOptionTable - synonym initialization} testobjconfig {
- deleteWindows
+} -cleanup {
+ killTables
+} -result {{1 16 -boolean} {2 16 -boolean}}
+test config-1.2 {Tk_CreateOptionTable - synonym initialization} -constraints {
+ testobjconfig
+} -body {
testobjconfig alltypes .a -synonym green
.a cget -color
-} {green}
-test config-1.3 {Tk_CreateOptionTable - option database initialization} testobjconfig {
- deleteWindows
- option clear
+} -cleanup {
+ killTables
+} -result {green}
+test config-1.3 {Tk_CreateOptionTable - option database initialization} -constraints {
+ testobjconfig
+} -body {
testobjconfig alltypes .a
option add *b.string different
testobjconfig alltypes .b
list [.a cget -string] [.b cget -string]
-} {foo different}
-test config-1.4 {Tk_CreateOptionTable - option database initialization} testobjconfig {
- deleteWindows
+} -cleanup {
+ killTables
option clear
+} -result {foo different}
+test config-1.4 {Tk_CreateOptionTable - option database initialization} -constraints {
+ testobjconfig
+} -body {
testobjconfig alltypes .a
option add *b.String bar
testobjconfig alltypes .b
list [.a cget -string] [.b cget -string]
-} {foo bar}
-test config-1.5 {Tk_CreateOptionTable - default initialization} testobjconfig {
- deleteWindows
+} -cleanup {
+ killTables
+ option clear
+} -result {foo bar}
+test config-1.5 {Tk_CreateOptionTable - default initialization} -constraints {
+ testobjconfig
+} -body {
testobjconfig alltypes .a
.a cget -relief
-} {raised}
-test config-1.6 {Tk_CreateOptionTable - chained tables} testobjconfig {
- deleteWindows
+} -cleanup {
killTables
+} -result {raised}
+test config-1.6 {Tk_CreateOptionTable - chained tables} -constraints {
+ testobjconfig
+} -body {
testobjconfig chain1 .a
testobjconfig chain2 .b
testobjconfig info chain2
-} {1 4 -three 2 2 -one}
-test config-1.7 {Tk_CreateOptionTable - chained tables} testobjconfig {
- deleteWindows
+} -cleanup {
killTables
+} -result {1 4 -three 2 2 -one}
+test config-1.7 {Tk_CreateOptionTable - chained tables} -constraints {
+ testobjconfig
+} -body {
testobjconfig chain2 .b
testobjconfig chain1 .a
testobjconfig info chain2
-} {1 4 -three 2 2 -one}
-test config-1.8 {Tk_CreateOptionTable - chained tables} testobjconfig {
- deleteWindows
+} -cleanup {
+ killTables
+} -result {1 4 -three 2 2 -one}
+test config-1.8 {Tk_CreateOptionTable - chained tables} -constraints {
+ testobjconfig
+} -body {
testobjconfig chain1 .a
testobjconfig chain2 .b
- list [catch {.a cget -four} msg] $msg [.a cget -one] \
- [.b cget -four] [.b cget -one]
-} {1 {unknown option "-four"} one four one}
-
-test config-2.1 {Tk_DeleteOptionTable - reference counts} testobjconfig {
- deleteWindows
+ .a cget -four
+} -cleanup {
killTables
+} -returnCodes error -result {unknown option "-four"}
+test config-1.9 {Tk_CreateOptionTable - chained tables} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig chain1 .a
+ testobjconfig chain2 .b
+ catch {.a cget -four}
+ list [.a cget -one] [.b cget -four] [.b cget -one]
+} -cleanup {
+ killTables
+} -result {one four one}
+
+
+test config-2.1 {Tk_DeleteOptionTable - reference counts} -constraints {
+ testobjconfig
+} -body {
+ set x {}
testobjconfig chain1 .a
testobjconfig chain2 .b
testobjconfig chain2 .c
deleteWindows
- set x {}
testobjconfig delete chain2
lappend x [testobjconfig info chain2] [testobjconfig info chain1]
testobjconfig delete chain2
lappend x [testobjconfig info chain2] [testobjconfig info chain1]
-} {{1 4 -three 2 2 -one} {2 2 -one} {} {1 2 -one}}
+} -cleanup {
+ killTables
+} -result {{1 4 -three 2 2 -one} {2 2 -one} {} {1 2 -one}}
# No tests for DestroyOptionHashTable; couldn't figure out how to test.
-test config-3.1 {Tk_InitOptions - priority of chained tables} testobjconfig {
- deleteWindows
+test config-3.1 {Tk_InitOptions - priority of chained tables} -constraints {
+ testobjconfig
+} -body {
testobjconfig chain1 .a
testobjconfig chain2 .b
list [.a cget -two] [.b cget -two]
-} {two {two and a half}}
-test config-3.2 {Tk_InitOptions - initialize from database} testobjconfig {
- deleteWindows
- option clear
+} -cleanup {
+ killTables
+} -result {two {two and a half}}
+test config-3.2 {Tk_InitOptions - initialize from database} -constraints {
+ testobjconfig
+} -body {
option add *a.color blue
testobjconfig alltypes .a
list [.a cget -color]
-} {blue}
-test config-3.3 {Tk_InitOptions - initialize from database} testobjconfig {
- deleteWindows
+} -cleanup {
+ killTables
option clear
+} -result {blue}
+test config-3.3 {Tk_InitOptions - initialize from database} -constraints {
+ testobjconfig
+} -body {
option add *a.justify bogus
testobjconfig alltypes .a
list [.a cget -justify]
-} {left}
-test config-3.4 {Tk_InitOptions - initialize from widget class} testobjconfig {
- deleteWindows
+} -cleanup {
+ killTables
+ option clear
+} -result {left}
+test config-3.4 {Tk_InitOptions - initialize from widget class} -constraints {
+ testobjconfig
+} -body {
testobjconfig alltypes .a
list [.a cget -color]
-} {red}
-test config-3.5 {Tk_InitOptions - no initial value} testobjconfig {
- deleteWindows
+} -cleanup {
+ killTables
+} -result {red}
+test config-3.5 {Tk_InitOptions - no initial value} -constraints {
+ testobjconfig
+} -body {
testobjconfig alltypes .a
.a cget -anchor
-} {}
-test config-3.6 {Tk_InitOptions - bad initial value} testobjconfig {
- deleteWindows
+} -cleanup {
+ killTables
+} -result {}
+test config-3.6 {Tk_InitOptions - bad initial value} -constraints {
+ testobjconfig
+} -body {
+ option add *a.color non-existent
+ testobjconfig alltypes .a
+} -cleanup {
+ killTables
option clear
+} -returnCodes error -result {unknown color name "non-existent"}
+test config-3.7 {Tk_InitOptions - bad initial value} -constraints {
+ testobjconfig
+} -body {
option add *a.color non-existent
- list [catch {testobjconfig alltypes .a} msg] $msg $errorInfo
-} {1 {unknown color name "non-existent"} {unknown color name "non-existent"
+ catch {testobjconfig alltypes .a}
+ return $errorInfo
+} -cleanup {
+ killTables
+ option clear
+} -result {unknown color name "non-existent"
(database entry for "-color" in widget ".a")
invoked from within
-"testobjconfig alltypes .a"}}
-option clear
-test config-3.7 {Tk_InitOptions - bad initial value} testobjconfig {
- deleteWindows
- list [catch {testobjconfig configerror} msg] $msg $errorInfo
-} {1 {expected integer but got "bogus"} {expected integer but got "bogus"
+"testobjconfig alltypes .a"}
+
+test config-3.8 {Tk_InitOptions - bad initial value} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig configerror
+} -returnCodes error -result {expected integer but got "bogus"}
+test config-3.9 {Tk_InitOptions - bad initial value} -constraints {
+ testobjconfig
+} -body {
+ catch {testobjconfig configerror}
+ return $errorInfo
+} -result {expected integer but got "bogus"
(default value for "-int")
invoked from within
-"testobjconfig configerror"}}
-option clear
+"testobjconfig configerror"}
-test config-4.1 {DoObjConfig - boolean} testobjconfig {
+test config-4.1 {DoObjConfig - boolean} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -boolean 0
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.2 {DoObjConfig - boolean} -constraints testobjconfig -setup {
catch {rename .foo {}}
- list [catch {testobjconfig alltypes .foo -boolean 0} msg] $msg [catch {.foo cget -boolean} result] $result [catch {rename .foo {}}]
-} {0 .foo 0 0 0}
-test config-4.2 {DoObjConfig - boolean} testobjconfig {
+} -body {
+ testobjconfig alltypes .foo -boolean 0
+ .foo cget -boolean
+} -cleanup {
+ killTables
+} -returnCodes ok -result {0}
+test config-4.3 {DoObjConfig - boolean} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -boolean 0
+ .foo cget -boolean
+ rename .foo {}
+} -cleanup {
+ killTables
+} -returnCodes ok
+test config-4.4 {DoObjConfig - boolean} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -boolean 1
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.5 {DoObjConfig - boolean} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -boolean 1
+ .foo cget -boolean
+} -cleanup {
+ killTables
+} -returnCodes ok -result {1}
+test config-4.6 {DoObjConfig - boolean} -constraints testobjconfig -setup {
catch {rename .foo {}}
- list [catch {testobjconfig alltypes .foo -boolean 1} msg] $msg [catch {.foo cget -boolean} result] $result [catch {rename .foo {}}]
-} {0 .foo 0 1 0}
-test config-4.3 {DoObjConfig - invalid boolean} testobjconfig {
+} -body {
+ testobjconfig alltypes .foo -boolean 1
+ .foo cget -boolean
+ rename .foo {}
+} -cleanup {
+ killTables
+} -returnCodes ok
+test config-4.7 {DoObjConfig - invalid boolean} -constraints {
+ testobjconfig
+} -setup {
catch {rename .foo {}}
- list [catch {testobjconfig alltypes .foo -boolean {}} msg] $msg
-} {1 {expected boolean value but got ""}}
-test config-4.4 {DoObjConfig - boolean internal value} testobjconfig {
+} -body {
+ testobjconfig alltypes .foo -boolean {}
+} -cleanup {
+ killTables
+} -returnCodes error -result {expected boolean value but got ""}
+test config-4.8 {DoObjConfig - boolean internal value} -constraints {
+ testobjconfig
+} -setup {
catch {rename .foo {}}
+} -body {
testobjconfig internal .foo -boolean 0
.foo cget -boolean
-} {0}
-test config-4.5 {DoObjConfig - integer} testobjconfig {
+} -cleanup {
+ killTables
+} -result {0}
+
+test config-4.9 {DoObjConfig - integer} -constraints testobjconfig -setup {
catch {rename .foo {}}
- list [catch {testobjconfig alltypes .foo -integer 3} msg] $msg [catch {.foo cget -integer} result] $result [catch {rename .foo {}}]
-} {0 .foo 0 3 0}
-test config-4.6 {DoObjConfig - invalid integer} testobjconfig {
+} -body {
+ testobjconfig alltypes .foo -integer 3
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.10 {DoObjConfig - integer} -constraints testobjconfig -setup {
catch {rename .foo {}}
- list [catch {testobjconfig alltypes .foo -integer bar} msg] $msg
-} {1 {expected integer but got "bar"}}
-test config-4.7 {DoObjConfig - integer internal value} testobjconfig {
+} -body {
+ testobjconfig alltypes .foo -integer 3
+ .foo cget -integer
+} -cleanup {
+ killTables
+} -returnCodes ok -result {3}
+test config-4.11 {DoObjConfig - integer} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -integer 3
+ .foo cget -integer
+ rename .foo {}
+} -cleanup {
+ killTables
+} -returnCodes ok
+test config-4.12 {DoObjConfig - invalid integer} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -integer bar
+} -cleanup {
+ killTables
+} -cleanup {
+ killTables
+} -returnCodes error -result {expected integer but got "bar"}
+test config-4.13 {DoObjConfig - integer internal value} -constraints {
+ testobjconfig
+} -setup {
catch {rename .foo {}}
+} -body {
testobjconfig internal .foo -integer 421
.foo cget -integer
-} {421}
-test config-4.8 {DoObjConfig - double} testobjconfig {
+} -cleanup {
+ killTables
+} -result {421}
+
+test config-4.14 {DoObjConfig - double} -constraints testobjconfig -setup {
catch {rename .foo {}}
- list [catch {testobjconfig alltypes .foo -double 3.14} msg] $msg [catch {.foo cget -double} result] $result [catch {rename .foo {}}]
-} {0 .foo 0 3.14 0}
-test config-4.9 {DoObjConfig - invalid double} testobjconfig {
+} -body {
+ testobjconfig alltypes .foo -double 3.14
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.15 {DoObjConfig - double} -constraints testobjconfig -setup {
catch {rename .foo {}}
- list [catch {testobjconfig alltypes .foo -double bar} msg] $msg
-} {1 {expected floating-point number but got "bar"}}
-test config-4.10 {DoObjConfig - double internal value} testobjconfig {
+} -body {
+ testobjconfig alltypes .foo -double 3.14
+ .foo cget -double
+} -cleanup {
+ killTables
+} -returnCodes ok -result {3.14}
+test config-4.16 {DoObjConfig - double} -constraints testobjconfig -setup {
catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -double 3.14
+ .foo cget -double
+ rename .foo {}
+} -cleanup {
+ killTables
+} -returnCodes ok
+test config-4.17 {DoObjConfig - invalid double} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -double bar
+} -cleanup {
+ killTables
+} -returnCodes error -result {expected floating-point number but got "bar"}
+test config-4.18 {DoObjConfig - double internal value} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
testobjconfig internal .foo -double 62.75
.foo cget -double
-} {62.75}
-test config-4.11 {DoObjConfig - string} testobjconfig {
- catch {destroy .foo}
- list [catch {testobjconfig alltypes .foo -string test} msg] $msg [catch {.foo cget -string} result] $result [destroy .foo]
-} {0 .foo 0 test {}}
-test config-4.12 {DoObjConfig - null string} testobjconfig {
- catch {destroy .foo}
- list [catch {testobjconfig alltypes .foo -string {}} msg] $msg [catch {.foo cget -string} result] $result [destroy .foo]
-} {0 .foo 0 {} {}}
-test config-4.13 {DoObjConfig - string internal value} testobjconfig {
+} -cleanup {
+ killTables
+} -result {62.75}
+
+test config-4.19 {DoObjConfig - string} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -string test
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.20 {DoObjConfig - string} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -string test
+ .foo cget -string
+} -cleanup {
+ killTables
+} -returnCodes ok -result {test}
+test config-4.21 {DoObjConfig - string} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -string test
+ .foo cget -string
+ rename .foo {}
+} -cleanup {
+ killTables
+} -returnCodes ok
+test config-4.22 {DoObjConfig - null string} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -string {}
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.23 {DoObjConfig - null string} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -string {}
+ .foo cget -string
+} -cleanup {
+ killTables
+} -returnCodes ok -result {}
+test config-4.24 {DoObjConfig - null string} -constraints testobjconfig -setup {
catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -string {}
+ .foo cget -string
+ rename .foo {}
+} -cleanup {
+ killTables
+} -returnCodes ok
+
+test config-4.25 {DoObjConfig - string internal value} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
testobjconfig internal .foo -string "this is a test"
.foo cget -string
-} {this is a test}
-test config-4.14 {DoObjConfig - string table} testobjconfig {
- catch {destroy .foo}
- list [catch {testobjconfig alltypes .foo -stringtable two} msg] $msg [catch {.foo cget -stringtable} result] $result [destroy .foo]
-} {0 .foo 0 two {}}
-test config-4.15 {DoObjConfig - invalid string table} testobjconfig {
- catch {destroy .foo}
- list [catch {testobjconfig alltypes .foo -stringtable foo} msg] $msg
-} {1 {bad stringtable "foo": must be one, two, three, or four}}
-test config-4.16 {DoObjConfig - new string table} testobjconfig {
- catch {destroy .foo}
+} -cleanup {
+ killTables
+} -result {this is a test}
+
+test config-4.26 {DoObjConfig - string table} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -stringtable two
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.27 {DoObjConfig - string table} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -stringtable two
+ .foo cget -stringtable
+} -cleanup {
+ killTables
+} -returnCodes ok -result {two}
+test config-4.28 {DoObjConfig - string table} -constraints testobjconfig -body {
testobjconfig alltypes .foo -stringtable two
- list [catch {.foo configure -stringtable three} msg] $msg [catch {.foo cget -stringtable} result] $result [destroy .foo]
-} {0 16 0 three {}}
-test config-4.17 {DoObjConfig - stringtable internal value} testobjconfig {
+ .foo cget -stringtable
+ rename .foo {}
+} -cleanup {
+ killTables
+} -returnCodes ok
+test config-4.29 {DoObjConfig - invalid string table} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -stringtable foo
+} -cleanup {
+ killTables
+} -returnCodes error -result {bad stringtable "foo": must be one, two, three, or four}
+
+test config-4.30 {DoObjConfig - new string table} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -stringtable two
+ .foo configure -stringtable three
+} -cleanup {
+ killTables
+} -returnCodes ok -result {16}
+test config-4.31 {DoObjConfig - new string table} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -stringtable two
+ .foo configure -stringtable three
+ .foo cget -stringtable
+} -cleanup {
+ killTables
+} -returnCodes ok -result {three}
+test config-4.32 {DoObjConfig - new string table} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -stringtable two
+ .foo configure -stringtable three
+ .foo cget -stringtable
+ rename .foo {}
+} -cleanup {
+ killTables
+} -returnCodes ok
+test config-4.33 {DoObjConfig - stringtable internal value} -constraints {
+ testobjconfig
+} -setup {
catch {rename .foo {}}
+} -body {
testobjconfig internal .foo -stringtable "four"
.foo cget -stringtable
-} {four}
-test config-4.18 {DoObjConfig - color} testobjconfig {
- catch {rename .foo {}}
- list [catch {testobjconfig alltypes .foo -color blue} msg] $msg [catch {.foo cget -color} result] $result [destroy .foo]
-} {0 .foo 0 blue {}}
-test config-4.19 {DoObjConfig - invalid color} testobjconfig {
- catch {destroy .foo}
- list [catch {testobjconfig alltypes .foo -color xxx} msg] $msg
-} {1 {unknown color name "xxx"}}
-test config-4.20 {DoObjConfig - color internal value} testobjconfig {
+} -cleanup {
+ killTables
+} -result {four}
+
+test config-4.34 {DoObjConfig - color} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -color blue
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.35 {DoObjConfig - color} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -color blue
+ .foo cget -color
+} -cleanup {
+ killTables
+} -returnCodes ok -result {blue}
+test config-4.36 {DoObjConfig - color} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -color blue
+ .foo cget -color
+ rename .foo {}
+} -cleanup {
+ killTables
+} -returnCodes ok
+test config-4.37 {DoObjConfig - invalid color} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -color xxx
+} -cleanup {
+ killTables
+} -returnCodes error -result {unknown color name "xxx"}
+test config-4.38 {DoObjConfig - color internal value} -constraints {
+ testobjconfig
+} -setup {
catch {rename .foo {}}
+} -body {
testobjconfig internal .foo -color purple
.foo cget -color
-} {purple}
-test config-4.21 {DoObjConfig - null color} testobjconfig {
- catch {rename .foo {}}
- list [catch {testobjconfig alltypes .foo -color {}} msg] $msg [catch {.foo cget -color} result] $result [destroy .foo]
-} {0 .foo 0 {} {}}
-test config-4.22 {DoObjConfig - getting rid of old color} testobjconfig {
- catch {destroy .foo}
+} -cleanup {
+ killTables
+} -result {purple}
+
+test config-4.39 {DoObjConfig - null color} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -color {}
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.40 {DoObjConfig - null color} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -color {}
+ .foo cget -color
+} -cleanup {
+ killTables
+} -returnCodes ok -result {}
+test config-4.41 {DoObjConfig - null color} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -color {}
+ .foo cget -color
+ rename .foo {}
+} -cleanup {
+ killTables
+} -returnCodes ok
+test config-4.42 {DoObjConfig - getting rid of old color} -constraints {
+ testobjconfig
+} -body {
testobjconfig alltypes .foo -color #333333
- list [catch {.foo configure -color #444444} msg] $msg [catch {.foo cget -color} result] $result [destroy .foo]
-} {0 32 0 #444444 {}}
-test config-4.23 {DoObjConfig - font} testobjconfig {
+ .foo configure -color #444444
+} -cleanup {
+ killTables
+} -returnCodes ok -result {32}
+test config-4.43 {DoObjConfig - getting rid of old color} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -color #333333
+ .foo configure -color #444444
+ .foo cget -color
+} -cleanup {
+ killTables
+} -returnCodes ok -result {#444444}
+test config-4.44 {DoObjConfig - getting rid of old color} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -color #333333
+ .foo configure -color #444444
+ .foo cget -color
+ rename .foo {}
+} -cleanup {
+ killTables
+} -returnCodes ok
+
+test config-4.45 {DoObjConfig - font} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -font {Helvetica 72}
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.46 {DoObjConfig - font} -constraints testobjconfig -setup {
catch {rename .foo {}}
- list [catch {testobjconfig alltypes .foo -font {Helvetica 72}} msg] $msg [catch {.foo cget -font} result] $result [destroy .foo]
-} {0 .foo 0 {Helvetica 72} {}}
-test config-4.24 {DoObjConfig - new font} testobjconfig {
+} -body {
+ testobjconfig alltypes .foo -font {Helvetica 72}
+ .foo cget -font
+} -cleanup {
+ killTables
+} -returnCodes ok -result {Helvetica 72}
+test config-4.47 {DoObjConfig - new font} -constraints testobjconfig -setup {
catch {rename .foo {}}
+} -body {
testobjconfig alltypes .foo -font {Courier 12}
- list [catch {.foo configure -font {Helvetica 72}} msg] $msg [catch {.foo cget -font} result] $result [destroy .foo]
-} {0 64 0 {Helvetica 72} {}}
-test config-4.25 {DoObjConfig - invalid font} testobjconfig {
+ .foo configure -font {Helvetica 72}
+} -cleanup {
+ killTables
+} -returnCodes ok -result {64}
+test config-4.48 {DoObjConfig - new font} -constraints testobjconfig -setup {
catch {rename .foo {}}
- list [catch {testobjconfig alltypes .foo -font {Helvetica 12 foo}} msg] $msg
-} {1 {unknown font style "foo"}}
-test config-4.26 {DoObjConfig - null font} testobjconfig {
+} -body {
+ testobjconfig alltypes .foo -font {Courier 12}
+ .foo configure -font {Helvetica 72}
+ .foo cget -font
+} -cleanup {
+ killTables
+} -returnCodes ok -result {Helvetica 72}
+test config-4.49 {DoObjConfig - invalid font} -constraints {
+ testobjconfig
+} -setup {
catch {rename .foo {}}
- list [catch {testobjconfig alltypes .foo -font {}} msg] $msg [catch {.foo cget -font} result] $result [destroy .foo]
-} {0 .foo 0 {} {}}
-test config-4.27 {DoObjConfig - font internal value} testobjconfig {
+} -body {
+ testobjconfig alltypes .foo -font {Helvetica 12 foo}
+} -cleanup {
+ killTables
+} -returnCodes error -result {unknown font style "foo"}
+test config-4.50 {DoObjConfig - null font} -constraints testobjconfig -setup {
catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -font {}
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.51 {DoObjConfig - null font} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -font {}
+ .foo cget -font
+} -cleanup {
+ killTables
+} -returnCodes ok -result {}
+test config-4.52 {DoObjConfig - font internal value} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
testobjconfig internal .foo -font {Times 16}
.foo cget -font
-} {Times 16}
-test config-4.28 {DoObjConfig - bitmap} testobjconfig {
- catch {destroy .foo}
- list [catch {testobjconfig alltypes .foo -bitmap gray75} msg] $msg [catch {.foo cget -bitmap} result] $result [destroy .foo]
-} {0 .foo 0 gray75 {}}
-test config-4.29 {DoObjConfig - new bitmap} testobjconfig {
- catch {destroy .foo}
+} -cleanup {
+ killTables
+} -result {Times 16}
+
+test config-4.53 {DoObjConfig - bitmap} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -bitmap gray75
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.54 {DoObjConfig - bitmap} -constraints testobjconfig -body {
testobjconfig alltypes .foo -bitmap gray75
- list [catch {.foo configure -bitmap gray50} msg] $msg [catch {.foo cget -bitmap} result] $result [destroy .foo]
-} {0 128 0 gray50 {}}
-test config-4.30 {DoObjConfig - invalid bitmap} testobjconfig {
- catch {destroy .foo}
- list [catch {testobjconfig alltypes .foo -bitmap foo} msg] $msg
-} {1 {bitmap "foo" not defined}}
-test config-4.31 {DoObjConfig - null bitmap} testobjconfig {
- catch {destroy .foo}
- list [catch {testobjconfig alltypes .foo -bitmap {}} msg] $msg [catch {.foo cget -bitmap} result] $result [destroy .foo]
-} {0 .foo 0 {} {}}
-test config-4.32 {DoObjConfig - bitmap internal value} testobjconfig {
+ .foo cget -bitmap
+} -cleanup {
+ killTables
+} -returnCodes ok -result {gray75}
+test config-4.55 {DoObjConfig - new bitmap} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -bitmap gray75
+ .foo configure -bitmap gray50
+} -cleanup {
+ killTables
+} -returnCodes ok -result {128}
+test config-4.56 {DoObjConfig - new bitmap} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -bitmap gray75
+ .foo configure -bitmap gray50
+ .foo cget -bitmap
+} -cleanup {
+ killTables
+} -returnCodes ok -result {gray50}
+test config-4.57 {DoObjConfig - invalid bitmap} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -bitmap foo
+} -cleanup {
+ killTables
+} -returnCodes error -result {bitmap "foo" not defined}
+test config-4.58 {DoObjConfig - null bitmap} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -bitmap {}
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.59 {DoObjConfig - null bitmap} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -bitmap {}
+ .foo cget -bitmap
+} -cleanup {
+ killTables
+} -returnCodes ok -result {}
+test config-4.60 {DoObjConfig - bitmap internal value} -constraints {
+ testobjconfig
+} -setup {
catch {rename .foo {}}
+} -body {
testobjconfig internal .foo -bitmap gray25
.foo cget -bitmap
-} {gray25}
-test config-4.33 {DoObjConfig - border} testobjconfig {
- catch {rename .foo {}}
- list [catch {testobjconfig alltypes .foo -border green} msg] $msg [catch {.foo cget -border} result] $result [destroy .foo]
-} {0 .foo 0 green {}}
-test config-4.34 {DoObjConfig - invalid border} testobjconfig {
- catch {destroy .foo}
- list [catch {testobjconfig alltypes .foo -border xxx} msg] $msg
-} {1 {unknown color name "xxx"}}
-test config-4.35 {DoObjConfig - null border} testobjconfig {
- catch {rename .foo {}}
- list [catch {testobjconfig alltypes .foo -border {}} msg] $msg [catch {.foo cget -border} result] $result [destroy .foo]
-} {0 .foo 0 {} {}}
-test config-4.36 {DoObjConfig - border internal value} testobjconfig {
+} -cleanup {
+ killTables
+} -result {gray25}
+
+test config-4.61 {DoObjConfig - border} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -border green
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.62 {DoObjConfig - border} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -border green
+ .foo cget -border
+} -cleanup {
+ killTables
+} -returnCodes ok -result {green}
+test config-4.63 {DoObjConfig - invalid border} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -border xxx
+} -cleanup {
+ killTables
+} -returnCodes error -result {unknown color name "xxx"}
+test config-4.64 {DoObjConfig - null border} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -border {}
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.65 {DoObjConfig - null border} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -border {}
+ .foo cget -border
+} -cleanup {
+ killTables
+} -returnCodes ok -result {}
+test config-4.66 {DoObjConfig - border internal value} -constraints {
+ testobjconfig
+} -setup {
catch {rename .foo {}}
+} -body {
testobjconfig internal .foo -border #123456
.foo cget -border
-} {#123456}
-test config-4.37 {DoObjConfig - getting rid of old border} testobjconfig {
- catch {destroy .foo}
+} -cleanup {
+ killTables
+} -result {#123456}
+test config-4.67 {DoObjConfig - getting rid of old border} -constraints {
+ testobjconfig
+} -body {
testobjconfig alltypes .foo -border #333333
- list [catch {.foo configure -border #444444} msg] $msg [catch {.foo cget -border} result] $result [destroy .foo]
-} {0 256 0 #444444 {}}
-test config-4.38 {DoObjConfig - relief} testobjconfig {
- catch {destroy .foo}
- list [catch {testobjconfig alltypes .foo -relief flat} msg] $msg [catch {.foo cget -relief} result] $result [destroy .foo]
-} {0 .foo 0 flat {}}
-test config-4.39 {DoObjConfig - invalid relief} testobjconfig {
- catch {destroy .foo}
- list [catch {testobjconfig alltypes .foo -relief foo} msg] $msg
-} {1 {bad relief "foo": must be flat, groove, raised, ridge, solid, or sunken}}
-test config-4.40 {DoObjConfig - new relief} testobjconfig {
- catch {destroy .foo}
- testobjconfig alltypes .foo -relief raised
- list [catch {.foo configure -relief flat} msg] $msg [catch {.foo cget -relief} result] $result [destroy .foo]
-} {0 512 0 flat {}}
-test config-4.41 {DoObjConfig - relief internal value} testobjconfig {
+ .foo configure -border #444444
+} -cleanup {
+ killTables
+} -returnCodes ok -result {256}
+test config-4.68 {DoObjConfig - getting rid of old border} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -border #333333
+ .foo configure -border #444444
+ .foo cget -border
+} -cleanup {
+ killTables
+} -returnCodes ok -result {#444444}
+
+test config-4.69 {DoObjConfig - relief} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -relief flat
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.70 {DoObjConfig - relief} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -relief flat
+ .foo cget -relief
+} -cleanup {
+ killTables
+} -returnCodes ok -result {flat}
+test config-4.71 {DoObjConfig - invalid relief} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -relief foo
+} -cleanup {
+ killTables
+} -returnCodes error -result {bad relief "foo": must be flat, groove, raised, ridge, solid, or sunken}
+test config-4.72 {DoObjConfig - relief internal value} -constraints testobjconfig -setup {
catch {rename .foo {}}
+} -body {
testobjconfig internal .foo -relief ridge
.foo cget -relief
-} {ridge}
-test config-4.42 {DoObjConfig - cursor} testobjconfig {
- catch {destroy .foo}
- list [catch {testobjconfig alltypes .foo -cursor arrow} msg] $msg [catch {.foo cget -cursor} result] $result [destroy .foo]
-} {0 .foo 0 arrow {}}
-test config-4.43 {DoObjConfig - invalid cursor} testobjconfig {
- catch {destroy .foo}
- list [catch {testobjconfig alltypes .foo -cursor foo} msg] $msg
-} {1 {bad cursor spec "foo"}}
-test config-4.44 {DoObjConfig - null cursor} testobjconfig {
- catch {destroy .foo}
- list [catch {testobjconfig alltypes .foo -cursor {}} msg] $msg [catch {.foo cget -cursor} result] $result [destroy .foo]
-} {0 .foo 0 {} {}}
-test config-4.45 {DoObjConfig - new cursor} testobjconfig {
- catch {destroy .foo}
+} -cleanup {
+ killTables
+} -result {ridge}
+test config-4.73 {DoObjConfig - new relief} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -relief raised
+ .foo configure -relief flat
+} -cleanup {
+ killTables
+} -returnCodes ok -result {512}
+test config-4.74 {DoObjConfig - new relief} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -relief raised
+ .foo configure -relief flat
+ .foo cget -relief
+} -cleanup {
+ killTables
+} -returnCodes ok -result {flat}
+
+test config-4.75 {DoObjConfig - cursor} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -cursor arrow
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.76 {DoObjConfig - cursor} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -cursor arrow
+ .foo cget -cursor
+} -cleanup {
+ killTables
+} -returnCodes ok -result {arrow}
+test config-4.77 {DoObjConfig - invalid cursor} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -cursor foo
+} -cleanup {
+ killTables
+} -returnCodes error -result {bad cursor spec "foo"}
+test config-4.78 {DoObjConfig - null cursor} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -cursor {}
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.79 {DoObjConfig - null cursor} -constraints testobjconfig -setup {
+ catch {rename .foo {}}
+} -body {
+ testobjconfig alltypes .foo -cursor {}
+ .foo cget -cursor
+} -cleanup {
+ killTables
+} -returnCodes ok -result {}
+test config-4.80 {DoObjConfig - new cursor} -constraints testobjconfig -body {
testobjconfig alltypes .foo -cursor xterm
- list [catch {.foo configure -cursor arrow} msg] $msg [catch {.foo cget -cursor} result] $result [destroy .foo]
-} {0 1024 0 arrow {}}
-test config-4.46 {DoObjConfig - cursor internal value} testobjconfig {
+ .foo configure -cursor arrow
+} -cleanup {
+ killTables
+} -returnCodes ok -result {1024}
+test config-4.81 {DoObjConfig - new cursor} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -cursor xterm
+ .foo configure -cursor arrow
+ .foo cget -cursor
+} -cleanup {
+ killTables
+} -returnCodes ok -result {arrow}
+test config-4.82 {DoObjConfig - cursor internal value} -constraints {
+ testobjconfig
+} -setup {
catch {rename .foo {}}
+} -body {
testobjconfig internal .foo -cursor watch
.foo cget -cursor
-} {watch}
-test config-4.47 {DoObjConfig - justify} testobjconfig {
- catch {destroy .foo}
- list [catch {testobjconfig alltypes .foo -justify center} msg] $msg [catch {.foo cget -justify} result] $result [destroy .foo]
-} {0 .foo 0 center {}}
-test config-4.48 {DoObjConfig - invalid justify} testobjconfig {
- catch {destroy .foo}
- list [catch {testobjconfig alltypes .foo -justify foo} msg] $msg
-} {1 {bad justification "foo": must be left, right, or center}}
-test config-4.49 {DoObjConfig - new justify} testobjconfig {
- catch {destroy .foo}
+} -cleanup {
+ killTables
+} -result {watch}
+
+test config-4.83 {DoObjConfig - justify} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -justify center
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.84 {DoObjConfig - justify} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -justify center
+ .foo cget -justify
+} -cleanup {
+ killTables
+} -returnCodes ok -result {center}
+test config-4.85 {DoObjConfig - invalid justify} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -justify foo
+} -cleanup {
+ killTables
+} -returnCodes error -result {bad justification "foo": must be left, right, or center}
+test config-4.86 {DoObjConfig - new justify} -constraints testobjconfig -body {
testobjconfig alltypes .foo -justify left
- list [catch {.foo configure -justify right} msg] $msg [catch {.foo cget -justify} result] $result [destroy .foo]
-} {0 2048 0 right {}}
-test config-4.50 {DoObjConfig - justify internal value} testobjconfig {
+ .foo configure -justify right
+} -cleanup {
+ killTables
+} -returnCodes ok -result {2048}
+test config-4.87 {DoObjConfig - new justify} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -justify left
+ .foo configure -justify right
+ .foo cget -justify
+} -cleanup {
+ killTables
+} -returnCodes ok -result {right}
+test config-4.88 {DoObjConfig - justify internal value} -constraints {
+ testobjconfig
+} -setup {
catch {rename .foo {}}
+} -body {
testobjconfig internal .foo -justify center
.foo cget -justify
-} {center}
-test config-4.51 {DoObjConfig - anchor} testobjconfig {
- catch {destroy .foo}
- list [catch {testobjconfig alltypes .foo -anchor center} msg] $msg [catch {.foo cget -anchor} result] $result [destroy .foo]
-} {0 .foo 0 center {}}
-test config-4.52 {DoObjConfig - invalid anchor} testobjconfig {
- catch {destroy .foo}
- list [catch {testobjconfig alltypes .foo -anchor foo} msg] $msg
-} {1 {bad anchor "foo": must be n, ne, e, se, s, sw, w, nw, or center}}
-test config-4.53 {DoObjConfig - new anchor} testobjconfig {
- catch {destroy .foo}
+} -cleanup {
+ killTables
+} -result {center}
+
+test config-4.89 {DoObjConfig - anchor} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -anchor center
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.90 {DoObjConfig - anchor} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -anchor center
+ .foo cget -anchor
+} -cleanup {
+ killTables
+} -returnCodes ok -result {center}
+test config-4.91 {DoObjConfig - invalid anchor} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -anchor foo
+} -cleanup {
+ killTables
+} -returnCodes error -result {bad anchor "foo": must be n, ne, e, se, s, sw, w, nw, or center}
+test config-4.92 {DoObjConfig - new anchor} -constraints testobjconfig -body {
testobjconfig alltypes .foo -anchor e
- list [catch {.foo configure -anchor n} msg] $msg [catch {.foo cget -anchor} result] $result [destroy .foo]
-} {0 4096 0 n {}}
-test config-4.54 {DoObjConfig - anchor internal value} testobjconfig {
+ .foo configure -anchor n
+} -cleanup {
+ killTables
+} -returnCodes ok -result {4096}
+test config-4.93 {DoObjConfig - new anchor} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -anchor e
+ .foo configure -anchor n
+ .foo cget -anchor
+} -cleanup {
+ killTables
+} -returnCodes ok -result {n}
+test config-4.94 {DoObjConfig - anchor internal value} -constraints {
+ testobjconfig
+} -setup {
catch {rename .foo {}}
+} -body {
testobjconfig internal .foo -anchor sw
.foo cget -anchor
-} {sw}
-test config-4.55 {DoObjConfig - pixel} testobjconfig {
- catch {destroy .foo}
- list [catch {testobjconfig alltypes .foo -pixel 42} msg] $msg [catch {.foo cget -pixel} result] $result [destroy .foo]
-} {0 .foo 0 42 {}}
-test config-4.56 {DoObjConfig - invalid pixel} testobjconfig {
- catch {destroy .foo}
- list [catch {testobjconfig alltypes .foo -pixel foo} msg] $msg
-} {1 {bad screen distance "foo"}}
-test config-4.57 {DoObjConfig - new pixel} testobjconfig {
- catch {destroy .foo}
+} -cleanup {
+ killTables
+} -result {sw}
+test config-4.95 {DoObjConfig - pixel} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -pixel 42
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.96 {DoObjConfig - pixel} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -pixel 42
+ .foo cget -pixel
+} -cleanup {
+ killTables
+} -returnCodes ok -result {42}
+test config-4.97 {DoObjConfig - invalid pixel} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -pixel foo
+} -cleanup {
+ killTables
+} -returnCodes error -result {bad screen distance "foo"}
+test config-4.98 {DoObjConfig - new pixel} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -pixel 42m
+ .foo configure -pixel 3c
+} -cleanup {
+ killTables
+} -returnCodes ok -result {8192}
+test config-4.99 {DoObjConfig - new pixel} -constraints testobjconfig -body {
testobjconfig alltypes .foo -pixel 42m
- list [catch {.foo configure -pixel 3c} msg] $msg [catch {.foo cget -pixel} result] $result [destroy .foo]
-} {0 8192 0 3c {}}
-test config-4.58 {DoObjConfig - pixel internal value} testobjconfig {
+ .foo configure -pixel 3c
+ .foo cget -pixel
+} -cleanup {
+ killTables
+} -returnCodes ok -result {3c}
+test config-4.100 {DoObjConfig - pixel internal value} -constraints {
+ testobjconfig
+} -setup {
catch {rename .foo {}}
+} -body {
testobjconfig internal .foo -pixel [winfo screenmmwidth .]m
- .foo cget -pixel
-} [winfo screenwidth .]
-test config-4.59 {DoObjConfig - window} testobjconfig {
- catch {destroy .foo}
- catch {destroy .bar}
+ set screenW [winfo screenwidth .]
+ set result [.foo cget -pixel]
+ expr {$screenW eq $result}
+} -cleanup {
+ killTables
+} -result {1}
+
+test config-4.101 {DoObjConfig - window} -constraints testobjconfig -body {
toplevel .bar
- list [catch {testobjconfig twowindows .foo -window .bar} msg] $msg [catch {.foo cget -window} result] $result [destroy .foo] [destroy .bar]
-} {0 .foo 0 .bar {} {}}
-test config-4.60 {DoObjConfig - invalid window} testobjconfig {
- catch {destroy .foo}
+ testobjconfig twowindows .foo -window .bar
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.102 {DoObjConfig - window} -constraints testobjconfig -body {
toplevel .bar
- list [catch {testobjconfig twowindows .foo -window foo} msg] $msg [destroy .bar]
-} {1 {bad window path name "foo"} {}}
-test config-4.61 {DoObjConfig - null window} testobjconfig {
- catch {destroy .foo}
- catch {destroy .bar}
+ testobjconfig twowindows .foo -window .bar
+ .foo cget -window
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.bar}
+test config-4.103 {DoObjConfig - invalid window} -constraints testobjconfig -body {
toplevel .bar
- list [catch {testobjconfig twowindows .foo -window {}} msg] $msg [catch {.foo cget -window} result] $result [destroy .foo]
-} {0 .foo 0 {} {}}
-test config-4.62 {DoObjConfig - new window} testobjconfig {
- catch {destroy .foo}
- catch {destroy .bar}
- catch {destroy .blamph}
+ testobjconfig twowindows .foo -window foo
+} -cleanup {
+ killTables
+} -returnCodes error -result {bad window path name "foo"}
+test config-4.104 {DoObjConfig - null window} -constraints testobjconfig -body {
+ toplevel .bar
+ testobjconfig twowindows .foo -window {}
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.105 {DoObjConfig - null window} -constraints testobjconfig -body {
+ toplevel .bar
+ testobjconfig twowindows .foo -window {}
+ .foo cget -window
+} -cleanup {
+ killTables
+} -returnCodes ok -result {}
+test config-4.106 {DoObjConfig - new window} -constraints testobjconfig -body {
toplevel .bar
toplevel .blamph
testobjconfig twowindows .foo -window .bar
- list [catch {.foo configure -window .blamph} msg] $msg [catch {.foo cget -window} result] $result [destroy .foo] [destroy .bar] [destroy .blamph]
-} {0 0 0 .blamph {} {} {}}
-test config-4.63 {DoObjConfig - window internal value} testobjconfig {
+ .foo configure -window .blamph
+} -cleanup {
+ killTables
+} -returnCodes ok -result {0}
+test config-4.107 {DoObjConfig - new window} -constraints testobjconfig -body {
+ toplevel .bar
+ toplevel .blamph
+ testobjconfig twowindows .foo -window .bar
+ .foo configure -window .blamph
+ .foo cget -window
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.blamph}
+test config-4.108 {DoObjConfig - window internal value} -constraints {
+ testobjconfig
+} -setup {
catch {rename .foo {}}
+} -body {
testobjconfig internal .foo -window .
.foo cget -window
-} {.}
-test config-4.64 {DoObjConfig - releasing old values} testobjconfig {
+} -cleanup {
+ killTables
+} -result {.}
+
+test config-4.109 {DoObjConfig - releasing old values} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
# This test doesn't generate a useful value to check; if an
# error occurs, it will be detected only by memory checking software
# such as Purify or Tcl's built-in checker.
- catch {rename .foo {}}
testobjconfig alltypes .foo -string {Test string} -color yellow \
-font {Courier 18} -bitmap questhead -border green -cursor cross \
-custom foobar
@@ -451,13 +1054,18 @@ test config-4.64 {DoObjConfig - releasing old values} testobjconfig {
-font {Times 8} -bitmap gray75 -border pink -cursor watch \
-custom barbaz
concat {}
-} {}
-test config-4.65 {DoObjConfig - releasing old values} testobjconfig {
+} -cleanup {
+ killTables
+} -result {}
+test config-4.110 {DoObjConfig - releasing old values} -constraints {
+ testobjconfig
+} -setup {
+ catch {rename .foo {}}
+} -body {
# This test doesn't generate a useful value to check; if an
# error occurs, it will be detected only by memory checking software
# such as Purify or Tcl's built-in checker.
- catch {rename .foo {}}
testobjconfig internal .foo -string {Test string} -color yellow \
-font {Courier 18} -bitmap questhead -border green -cursor cross \
-custom foobar
@@ -465,421 +1073,844 @@ test config-4.65 {DoObjConfig - releasing old values} testobjconfig {
-font {Times 8} -bitmap gray75 -border pink -cursor watch \
-custom barbaz
concat {}
-} {}
-test config-4.66 {DoObjConfig - custom} testobjconfig {
- catch {destroy .foo}
- list [catch {testobjconfig alltypes .foo -custom test} msg] $msg [catch {.foo cget -custom} result] $result [destroy .foo]
-} {0 .foo 0 TEST {}}
-test config-4.67 {DoObjConfig - null custom} testobjconfig {
- catch {destroy .foo}
- list [catch {testobjconfig alltypes .foo -custom {}} msg] $msg [catch {.foo cget -custom} result] $result [destroy .foo]
-} {0 .foo 0 {} {}}
-test config-4.68 {DoObjConfig - custom internal value} testobjconfig {
+} -cleanup {
+ killTables
+} -result {}
+
+test config-4.111 {DoObjConfig - custom} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -custom test
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.112 {DoObjConfig - custom} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -custom test
+ .foo cget -custom
+} -cleanup {
+ killTables
+} -returnCodes ok -result {TEST}
+test config-4.113 {DoObjConfig - null custom} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -custom {}
+} -cleanup {
+ killTables
+} -returnCodes ok -result {.foo}
+test config-4.114 {DoObjConfig - null custom} -constraints testobjconfig -body {
+ testobjconfig alltypes .foo -custom {}
+ .foo cget -custom
+} -cleanup {
+ killTables
+} -returnCodes ok -result {}
+test config-4.115 {DoObjConfig - custom internal value} -constraints {
+ testobjconfig
+} -setup {
catch {rename .foo {}}
+} -body {
testobjconfig internal .foo -custom "this is a test"
.foo cget -custom
-} {THIS IS A TEST}
+} -cleanup {
+ killTables
+} -result {THIS IS A TEST}
-test config-5.1 {ObjectIsEmpty - object is already string} testobjconfig {
- catch {destroy .foo}
+
+test config-5.1 {ObjectIsEmpty - object is already string} -constraints {
+ testobjconfig
+} -body {
testobjconfig alltypes .foo -color [format ""]
.foo cget -color
-} {}
-test config-5.2 {ObjectIsEmpty - object is already string} testobjconfig {
- catch {destroy .foo}
- list [catch {testobjconfig alltypes .foo -color [format " "]} msg] $msg
-} {1 {unknown color name " "}}
-test config-5.3 {ObjectIsEmpty - must convert back to string} testobjconfig {
- catch {destroy .foo}
+} -cleanup {
+ killTables
+} -result {}
+test config-5.2 {ObjectIsEmpty - object is already string} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .foo -color [format " "]
+} -cleanup {
+ killTables
+} -returnCodes error -result {unknown color name " "}
+test config-5.3 {ObjectIsEmpty - must convert back to string} -constraints {
+ testobjconfig
+} -body {
testobjconfig alltypes .foo -color [list]
.foo cget -color
-} {}
+} -cleanup {
+ killTables
+} -result {}
-deleteWindows
-if {[testConstraint testobjconfig]} {
+
+test config-6.1 {GetOptionFromObj - cached answer} -constraints {
+ testobjconfig
+} -body {
testobjconfig chain2 .a
- testobjconfig alltypes .b
-}
-test config-6.1 {GetOptionFromObj - cached answer} testobjconfig {
list [.a cget -three] [.a cget -three]
-} {three three}
-test config-6.2 {GetOptionFromObj - exact match} testobjconfig {
+} -cleanup {
+ killTables
+} -result {three three}
+test config-6.2 {GetOptionFromObj - exact match} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig chain2 .a
.a cget -one
-} {one}
-test config-6.3 {GetOptionFromObj - abbreviation} testobjconfig {
+} -cleanup {
+ killTables
+} -result {one}
+test config-6.3 {GetOptionFromObj - abbreviation} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig chain2 .a
.a cget -fo
-} {four}
-test config-6.4 {GetOptionFromObj - ambiguous abbreviation} testobjconfig {
- list [catch {.a cget -on} msg] $msg
-} {1 {unknown option "-on"}}
-test config-6.5 {GetOptionFromObj - duplicate options in different tables} testobjconfig {
+} -cleanup {
+ killTables
+} -result {four}
+test config-6.4 {GetOptionFromObj - ambiguous abbreviation} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig chain2 .a
+ .a cget -on
+} -cleanup {
+ killTables
+} -cleanup {
+ killTables
+} -returnCodes error -result {unknown option "-on"}
+test config-6.5 {GetOptionFromObj - duplicate options in different tables} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig chain2 .a
.a cget -tw
-} {two and a half}
-test config-6.6 {GetOptionFromObj - synonym} testobjconfig {
+} -cleanup {
+ killTables
+} -result {two and a half}
+test config-6.6 {GetOptionFromObj - synonym} -constraints testobjconfig -body {
+ testobjconfig alltypes .b
.b cget -synonym
-} {red}
+} -cleanup {
+ killTables
+} -result {red}
+
-deleteWindows
if {[testConstraint testobjconfig]} {
testobjconfig alltypes .a
}
-test config-7.1 {Tk_SetOptions - basics} testobjconfig {
+test config-7.1 {Tk_SetOptions - basics} -constraints testobjconfig -body {
.a configure -color green -rel sunken
list [.a cget -color] [.a cget -relief]
-} {green sunken}
-test config-7.2 {Tk_SetOptions - bogus option name} testobjconfig {
- list [catch {.a configure -bogus} msg] $msg
-} {1 {unknown option "-bogus"}}
-test config-7.3 {Tk_SetOptions - synonym} testobjconfig {
+} -result {green sunken}
+test config-7.2 {Tk_SetOptions - bogus option name} -constraints {
+ testobjconfig
+} -body {
+ .a configure -bogus
+} -returnCodes error -result {unknown option "-bogus"}
+test config-7.3 {Tk_SetOptions - synonym} -constraints testobjconfig -body {
.a configure -synonym blue
.a cget -color
-} {blue}
-test config-7.4 {Tk_SetOptions - missing value} testobjconfig {
- list [catch {.a configure -color green -relief} msg] $msg [.a cget -color]
-} {1 {value for "-relief" missing} green}
-test config-7.5 {Tk_SetOptions - saving old values} testobjconfig {
+} -result {blue}
+test config-7.4 {Tk_SetOptions - missing value} -constraints {
+ testobjconfig
+} -body {
+ .a configure -color green -relief
+} -returnCodes error -result {value for "-relief" missing}
+test config-7.5 {Tk_SetOptions - missing value} -constraints {
+ testobjconfig
+} -body {
+ catch {.a configure -color green -relief}
+ .a cget -color
+} -result {green}
+test config-7.6 {Tk_SetOptions - saving old values} -constraints {
+ testobjconfig
+} -body {
+ .a configure -color red -int 7 -relief raised -double 3.14159
+ .a csave -color green -int 432 -relief sunken -double 2.0 -color bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test config-7.7 {Tk_SetOptions - saving old values} -constraints {
+ testobjconfig
+} -body {
.a configure -color red -int 7 -relief raised -double 3.14159
- list [catch {.a csave -color green -int 432 -relief sunken \
- -double 2.0 -color bogus} msg] $msg [.a cget -color] \
- [.a cget -int] [.a cget -relief] [.a cget -double]
-} {1 {unknown color name "bogus"} red 7 raised 3.14159}
-test config-7.6 {Tk_SetOptions - error in DoObjConfig call} testobjconfig {
- list [catch {.a configure -color bogus} msg] $msg $errorInfo
-} {1 {unknown color name "bogus"} {unknown color name "bogus"
+ catch {.a csave -color green -int 432 -relief sunken -double 2.0 -color bogus}
+ list [.a cget -color] [.a cget -int] [.a cget -relief] [.a cget -double]
+} -result {red 7 raised 3.14159}
+
+test config-7.8 {Tk_SetOptions - error in DoObjConfig call} -constraints {
+ testobjconfig
+} -body {
+ .a configure -color bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test config-7.9 {Tk_SetOptions - error in DoObjConfig call} -constraints {
+ testobjconfig
+} -body {
+ catch {.a configure -color bogus}
+ return $errorInfo
+} -result {unknown color name "bogus"
(processing "-color" option)
invoked from within
-".a configure -color bogus"}}
-test config-7.7 {Tk_SetOptions - synonym name in error message} testobjconfig {
- list [catch {.a configure -synonym bogus} msg] $msg $errorInfo
-} {1 {unknown color name "bogus"} {unknown color name "bogus"
+".a configure -color bogus"}
+
+test config-7.10 {Tk_SetOptions - synonym name in error message} -constraints {
+ testobjconfig
+} -body {
+ .a configure -synonym bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test config-7.11 {Tk_SetOptions - synonym name in error message} -constraints {
+ testobjconfig
+} -body {
+ catch {.a configure -synonym bogus}
+ return $errorInfo
+} -result {unknown color name "bogus"
(processing "-synonym" option)
invoked from within
-".a configure -synonym bogus"}}
-test config-7.8 {Tk_SetOptions - returning mask} testobjconfig {
+".a configure -synonym bogus"}
+test config-7.12 {Tk_SetOptions - returning mask} -constraints testobjconfig -body {
format %x [.a configure -color red -int 7 -relief raised -double 3.14159]
-} {226}
-test config-7.9 {Tk_SetOptions - error in DoObjConfig with custom option} testobjconfig {
- list [catch {.a configure -custom bad} msg] $msg $errorInfo
-} {1 {expected good value, got "BAD"} {expected good value, got "BAD"
+} -result {226}
+test config-7.13 {Tk_SetOptions - error in DoObjConfig with custom option} -constraints {
+ testobjconfig
+} -body {
+ .a configure -custom bad
+} -returnCodes error -result {expected good value, got "BAD"}
+test config-7.14 {Tk_SetOptions - error in DoObjConfig with custom option} -constraints {
+ testobjconfig
+} -body {
+ catch {.a configure -custom bad}
+ return $errorInfo
+} -result {expected good value, got "BAD"
(processing "-custom" option)
invoked from within
-".a configure -custom bad"}}
+".a configure -custom bad"}
+if {[testConstraint testobjconfig]} {
+ killTables
+}
-test config-8.1 {Tk_RestoreSavedOptions - restore in proper order} testobjconfig {
- deleteWindows
+
+test config-8.1 {Tk_RestoreSavedOptions - restore in proper order} -constraints {
+ testobjconfig
+} -body {
testobjconfig alltypes .a
- list [catch {.a csave -color green -color black -color blue \
- -color #ffff00 -color #ff00ff -color bogus} msg] $msg \
- [.a cget -color]
-} {1 {unknown color name "bogus"} red}
-test config-8.2 {Tk_RestoreSavedOptions - freeing object memory} testobjconfig {
- deleteWindows
+ .a csave -color green -color black -color blue \
+ -color #ffff00 -color #ff00ff -color bogus \
+} -cleanup {
+ killTables
+} -returnCodes error -result {unknown color name "bogus"}
+test config-8.2 {Tk_RestoreSavedOptions - restore in proper order} -constraints {
+ testobjconfig
+} -body {
testobjconfig alltypes .a
- .a csave -color green -color black -color blue -color #ffff00 \
- -color #ff00ff
-} {32}
-test config-8.3 {Tk_RestoreSavedOptions - boolean internal form} testobjconfig {
- deleteWindows
+ catch {.a csave -color green -color black -color blue \
+ -color #ffff00 -color #ff00ff -color bogus}
+ .a cget -color
+} -cleanup {
+ killTables
+} -result {red}
+test config-8.3 {Tk_RestoreSavedOptions - freeing object memory} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig alltypes .a
+ .a csave -color green -color black -color blue -color #ffff00 -color #ff00ff
+} -cleanup {
+ killTables
+} -result {32}
+test config-8.4 {Tk_RestoreSavedOptions - boolean internal form} -constraints {
+ testobjconfig
+} -body {
testobjconfig internal .a
- list [catch {.a csave -boolean 0 -color bogus}] [.a cget -boolean]
-} {1 1}
-test config-8.4 {Tk_RestoreSavedOptions - integer internal form} testobjconfig {
- deleteWindows
+ .a csave -boolean 0 -color bogus
+} -cleanup {
+ killTables
+} -returnCodes error -match glob -result *
+test config-8.5 {Tk_RestoreSavedOptions - boolean internal form} -constraints {
+ testobjconfig
+} -body {
testobjconfig internal .a
- list [catch {.a csave -integer 24 -color bogus}] [.a cget -integer]
-} {1 148962237}
-test config-8.5 {Tk_RestoreSavedOptions - double internal form} testobjconfig {
- deleteWindows
+ catch {.a csave -boolean 0 -color bogus}
+ .a cget -boolean
+} -cleanup {
+ killTables
+} -result {1}
+test config-8.6 {Tk_RestoreSavedOptions - integer internal form} -constraints {
+ testobjconfig
+} -body {
testobjconfig internal .a
- list [catch {.a csave -double 62.4 -color bogus}] [.a cget -double]
-} {1 3.14159}
-test config-8.6 {Tk_RestoreSavedOptions - string internal form} testobjconfig {
- deleteWindows
+ .a csave -integer 24 -color bogus
+} -cleanup {
+ killTables
+} -returnCodes error -match glob -result *
+test config-8.7 {Tk_RestoreSavedOptions - integer internal form} -constraints {
+ testobjconfig
+} -body {
testobjconfig internal .a
- list [catch {.a csave -string "A long string" -color bogus}] \
- [.a cget -string]
-} {1 foo}
-test config-8.7 {Tk_RestoreSavedOptions - string table internal form} testobjconfig {
- deleteWindows
+ catch {.a csave -integer 24 -color bogus}
+ .a cget -integer
+} -cleanup {
+ killTables
+} -result {148962237}
+test config-8.8 {Tk_RestoreSavedOptions - double internal form} -constraints {
+ testobjconfig
+} -body {
testobjconfig internal .a
- list [catch {.a csave -stringtable three -color bogus}] \
- [.a cget -stringtable]
-} {1 one}
-test config-8.8 {Tk_RestoreSavedOptions - color internal form} testobjconfig {
- deleteWindows
+ catch {.a csave -double 62.4 -color bogus}
+ .a cget -double
+} -cleanup {
+ killTables
+} -result {3.14159}
+test config-8.9 {Tk_RestoreSavedOptions - string internal form} -constraints {
+ testobjconfig
+} -body {
testobjconfig internal .a
- list [catch {.a csave -color green -color bogus}] [.a cget -color]
-} {1 red}
-test config-8.9 {Tk_RestoreSavedOptions - font internal form} {testobjconfig nonPortable} {
- deleteWindows
+ catch {.a csave -string "A long string" -color bogus}
+ .a cget -string
+} -cleanup {
+ killTables
+} -result {foo}
+test config-8.10 {Tk_RestoreSavedOptions - string table internal form} -constraints {
+ testobjconfig
+} -body {
testobjconfig internal .a
- list [catch {.a csave -font {Times 12} -color bogus}] [.a cget -font]
-} {1 {Helvetica 12}}
-test config-8.10 {Tk_RestoreSavedOptions - bitmap internal form} testobjconfig {
- deleteWindows
+ catch {.a csave -stringtable three -color bogus}
+ .a cget -stringtable
+} -cleanup {
+ killTables
+} -result {one}
+test config-8.11 {Tk_RestoreSavedOptions - color internal form} -constraints {
+ testobjconfig
+} -body {
testobjconfig internal .a
- list [catch {.a csave -bitmap questhead -color bogus}] [.a cget -bitmap]
-} {1 gray50}
-test config-8.11 {Tk_RestoreSavedOptions - border internal form} testobjconfig {
- deleteWindows
+ catch {.a csave -color green -color bogus}
+ .a cget -color
+} -cleanup {
+ killTables
+} -result {red}
+test config-8.12 {Tk_RestoreSavedOptions - font internal form} -constraints {
+ testobjconfig nonPortable
+} -body {
testobjconfig internal .a
- list [catch {.a csave -border brown -color bogus}] [.a cget -border]
-} {1 blue}
-test config-8.12 {Tk_RestoreSavedOptions - relief internal form} testobjconfig {
- deleteWindows
+ catch {.a csave -font {Times 12} -color bogus}
+ .a cget -font
+} -cleanup {
+ killTables
+} -result {Helvetica 12}
+test config-8.13 {Tk_RestoreSavedOptions - bitmap internal form} -constraints {
+ testobjconfig
+} -body {
testobjconfig internal .a
- list [catch {.a csave -relief sunken -color bogus}] [.a cget -relief]
-} {1 raised}
-test config-8.13 {Tk_RestoreSavedOptions - cursor internal form} testobjconfig {
- deleteWindows
+ catch {.a csave -bitmap questhead -color bogus}
+ .a cget -bitmap
+} -cleanup {
+ killTables
+} -result {gray50}
+test config-8.14 {Tk_RestoreSavedOptions - border internal form} -constraints {
+ testobjconfig
+} -body {
testobjconfig internal .a
- list [catch {.a csave -cursor watch -color bogus}] [.a cget -cursor]
-} {1 xterm}
-test config-8.14 {Tk_RestoreSavedOptions - justify internal form} testobjconfig {
- deleteWindows
+ catch {.a csave -border brown -color bogus}
+ .a cget -border
+} -cleanup {
+ killTables
+} -result {blue}
+test config-8.15 {Tk_RestoreSavedOptions - relief internal form} -constraints {
+ testobjconfig
+} -body {
testobjconfig internal .a
- list [catch {.a csave -justify right -color bogus}] [.a cget -justify]
-} {1 left}
-test config-8.15 {Tk_RestoreSavedOptions - anchor internal form} testobjconfig {
- deleteWindows
+ catch {.a csave -relief sunken -color bogus}
+ .a cget -relief
+} -cleanup {
+ killTables
+} -result {raised}
+test config-8.16 {Tk_RestoreSavedOptions - cursor internal form} -constraints {
+ testobjconfig
+} -body {
testobjconfig internal .a
- list [catch {.a csave -anchor center -color bogus}] [.a cget -anchor]
-} {1 n}
-test config-8.16 {Tk_RestoreSavedOptions - window internal form} testobjconfig {
- deleteWindows
+ catch {.a csave -cursor watch -color bogus}
+ .a cget -cursor
+} -cleanup {
+ killTables
+} -result {xterm}
+test config-8.17 {Tk_RestoreSavedOptions - justify internal form} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig internal .a
+ catch {.a csave -justify right -color bogus}
+ .a cget -justify
+} -cleanup {
+ killTables
+} -result {left}
+test config-8.18 {Tk_RestoreSavedOptions - anchor internal form} -constraints {
+ testobjconfig
+} -body {
+ testobjconfig internal .a
+ catch {.a csave -anchor center -color bogus}
+ .a cget -anchor
+} -cleanup {
+ killTables
+} -result {n}
+test config-8.19 {Tk_RestoreSavedOptions - window internal form} -constraints {
+ testobjconfig
+} -body {
testobjconfig internal .a -window .a
- list [catch {.a csave -window .a -color bogus}] [.a cget -window]
-} {1 .a}
-test config-8.17 {Tk_RestoreSavedOptions - custom internal form} testobjconfig {
- deleteWindows
+ catch {.a csave -window .a -color bogus}
+ .a cget -window
+} -cleanup {
+ killTables
+} -result {.a}
+test config-8.20 {Tk_RestoreSavedOptions - custom internal form} -constraints {
+ testobjconfig
+} -body {
testobjconfig internal .a -custom "foobar"
- list [catch {.a csave -custom "barbaz" -color bogus}] [.a cget -custom]
-} {1 FOOBAR}
+ catch {.a csave -custom "barbaz" -color bogus}
+ .a cget -custom
+} -cleanup {
+ killTables
+} -result {FOOBAR}
# Most of the tests below will cause memory leakage if there is a
# problem. This may not be evident unless the tests are run in
# conjunction with a memory usage analyzer such as Purify.
-test config-9.1 {Tk_FreeConfigOptions/FreeResources - string internal form} testobjconfig {
- catch {destroy .foo}
+test config-9.1 {Tk_FreeConfigOptions/FreeResources - string internal form} -constraints {
+ testobjconfig
+} -body {
testobjconfig internal .foo
.foo configure -string "two words"
destroy .foo
-} {}
-test config-9.2 {Tk_FreeConfigOptions/FreeResources - color internal form} testobjconfig {
- catch {destroy .foo}
+} -result {}
+test config-9.2 {Tk_FreeConfigOptions/FreeResources - color internal form} -constraints {
+ testobjconfig
+} -body {
testobjconfig internal .foo
.foo configure -color yellow
destroy .foo
-} {}
-test config-9.3 {Tk_FreeConfigOptions/FreeResources - color} testobjconfig {
- catch {destroy .foo}
+} -result {}
+test config-9.3 {Tk_FreeConfigOptions/FreeResources - color} -constraints {
+ testobjconfig
+} -body {
testobjconfig alltypes .foo
.foo configure -color [format blue]
destroy .foo
-} {}
-test config-9.4 {Tk_FreeConfigOptions/FreeResources - font internal form} testobjconfig {
- catch {destroy .foo}
+} -result {}
+test config-9.4 {Tk_FreeConfigOptions/FreeResources - font internal form} -constraints {
+ testobjconfig
+} -body {
testobjconfig internal .foo
.foo configure -font {Courier 20}
destroy .foo
-} {}
-test config-9.5 {Tk_FreeConfigOptions/FreeResources - font} testobjconfig {
- catch {destroy .foo}
+} -result {}
+test config-9.5 {Tk_FreeConfigOptions/FreeResources - font} -constraints {
+ testobjconfig
+} -body {
testobjconfig alltypes .foo
.foo configure -font [format {Courier 24}]
destroy .foo
-} {}
-test config-9.6 {Tk_FreeConfigOptions/FreeResources - bitmap internal form} testobjconfig {
- catch {destroy .foo}
+} -result {}
+test config-9.6 {Tk_FreeConfigOptions/FreeResources - bitmap internal form} -constraints {
+ testobjconfig
+} -body {
testobjconfig internal .foo
.foo configure -bitmap gray75
destroy .foo
-} {}
-test config-9.7 {Tk_FreeConfigOptions/FreeResources - bitmap} testobjconfig {
- catch {destroy .foo}
+} -result {}
+test config-9.7 {Tk_FreeConfigOptions/FreeResources - bitmap} -constraints {
+ testobjconfig
+} -body {
testobjconfig alltypes .foo
.foo configure -bitmap [format gray75]
destroy .foo
-} {}
-test config-9.8 {Tk_FreeConfigOptions/FreeResources - border internal form} testobjconfig {
- catch {destroy .foo}
+} -result {}
+test config-9.8 {Tk_FreeConfigOptions/FreeResources - border internal form} -constraints {
+ testobjconfig
+} -body {
testobjconfig internal .foo
.foo configure -border orange
destroy .foo
-} {}
-test config-9.9 {Tk_FreeConfigOptions/FreeResources - border} testobjconfig {
- catch {destroy .foo}
+} -result {}
+test config-9.9 {Tk_FreeConfigOptions/FreeResources - border} -constraints {
+ testobjconfig
+} -body {
testobjconfig alltypes .foo
.foo configure -border [format blue]
destroy .foo
-} {}
-test config-9.10 {Tk_FreeConfigOptions/FreeResources - cursor internal form} testobjconfig {
- catch {destroy .foo}
+} -result {}
+test config-9.10 {Tk_FreeConfigOptions/FreeResources - cursor internal form} -constraints {
+ testobjconfig
+} -body {
testobjconfig internal .foo
.foo configure -cursor cross
destroy .foo
-} {}
-test config-9.11 {Tk_FreeConfigOptions/FreeResources - cursor} testobjconfig {
- catch {destroy .foo}
+} -result {}
+test config-9.11 {Tk_FreeConfigOptions/FreeResources - cursor} -constraints {
+ testobjconfig
+} -body {
testobjconfig alltypes .foo
.foo configure -cursor [format watch]
destroy .foo
-} {}
-test config-9.12 {Tk_FreeConfigOptions/FreeResources - not special} testobjconfig {
- catch {destroy .foo}
+} -result {}
+test config-9.12 {Tk_FreeConfigOptions/FreeResources - not special} -constraints {
+ testobjconfig
+} -body {
testobjconfig alltypes .foo
.foo configure -integer [format 27]
destroy .foo
-} {}
-test config-9.13 {Tk_FreeConfigOptions/FreeResources - custom internal form} testobjconfig {
+} -result {}
+test config-9.13 {Tk_FreeConfigOptions/FreeResources - custom internal form} -constraints {
+ testobjconfig
+} -body {
catch {destroy .fpp}
testobjconfig internal .foo
.foo configure -custom "foobar"
destroy .foo
-} {}
+} -result {}
+if {[testConstraint testobjconfig]} {
+ killTables
+}
+
-test config-10.1 {Tk_GetOptionInfo - one item} testobjconfig {
- catch {destroy .foo}
+test config-10.1 {Tk_GetOptionInfo - one item} -constraints testobjconfig -body {
testobjconfig alltypes .foo
.foo configure -relief groove
.foo configure -relief
-} {-relief relief Relief raised groove}
-test config-10.2 {Tk_GetOptionInfo - one item, synonym} testobjconfig {
- catch {destroy .foo}
+} -cleanup {
+ destroy .foo
+} -result {-relief relief Relief raised groove}
+test config-10.2 {Tk_GetOptionInfo - one item, synonym} -constraints {
+ testobjconfig
+} -body {
testobjconfig alltypes .foo
.foo configure -color black
.foo configure -synonym
-} {-color color Color red black}
-test config-10.3 {Tk_GetOptionInfo - all items} testobjconfig {
- catch {destroy .foo}
+} -cleanup {
+ destroy .foo
+} -result {-color color Color red black}
+test config-10.3 {Tk_GetOptionInfo - all items} -constraints {
+ testobjconfig
+} -body {
testobjconfig alltypes .foo -font {Helvetica 18} -integer 13563
.foo configure
-} {{-boolean boolean Boolean 1 1} {-integer integer Integer 7 13563} {-double double Double 3.14159 3.14159} {-string string String foo foo} {-stringtable StringTable stringTable one one} {-color color Color red red} {-font font Font {Helvetica 12} {Helvetica 18}} {-bitmap bitmap Bitmap gray50 gray50} {-border border Border blue blue} {-relief relief Relief raised raised} {-cursor cursor Cursor xterm xterm} {-justify {} {} left left} {-anchor anchor Anchor {} {}} {-pixel pixel Pixel 1 1} {-custom {} {} {} {}} {-synonym -color}}
-test config-10.4 {Tk_GetOptionInfo - chaining through tables} testobjconfig {
- catch {destroy .foo}
+} -cleanup {
+ destroy .foo
+} -result {{-boolean boolean Boolean 1 1} {-integer integer Integer 7 13563} {-double double Double 3.14159 3.14159} {-string string String foo foo} {-stringtable StringTable stringTable one one} {-color color Color red red} {-font font Font {Helvetica 12} {Helvetica 18}} {-bitmap bitmap Bitmap gray50 gray50} {-border border Border blue blue} {-relief relief Relief raised raised} {-cursor cursor Cursor xterm xterm} {-justify {} {} left left} {-anchor anchor Anchor {} {}} {-pixel pixel Pixel 1 1} {-custom {} {} {} {}} {-synonym -color}}
+test config-10.4 {Tk_GetOptionInfo - chaining through tables} -constraints testobjconfig -body {
testobjconfig chain2 .foo -one asdf -three xyzzy
.foo configure
-} {{-three three Three three xyzzy} {-four four Four four four} {-two two Two {two and a half} {two and a half}} {-oneAgain oneAgain OneAgain {one again} {one again}} {-one one One one asdf} {-two two Two two {two and a half}}}
+} -cleanup {
+ destroy .foo
+} -result {{-three three Three three xyzzy} {-four four Four four four} {-two two Two {two and a half} {two and a half}} {-oneAgain oneAgain OneAgain {one again} {one again}} {-one one One one asdf} {-two two Two two {two and a half}}}
+if {[testConstraint testobjconfig]} {
+ killTables
+}
+
-deleteWindows
if {[testConstraint testobjconfig]} {
testobjconfig alltypes .a
}
-test config-11.1 {GetConfigList - synonym} testobjconfig {
+test config-11.1 {GetConfigList - synonym} -constraints testobjconfig -body {
lindex [.a configure] end
-} {-synonym -color}
-test config-11.2 {GetConfigList - null database names} testobjconfig {
+} -result {-synonym -color}
+test config-11.2 {GetConfigList - null database names} -constraints {
+ testobjconfig
+} -body {
.a configure -justify
-} {-justify {} {} left left}
-test config-11.3 {GetConfigList - null default and current value} testobjconfig {
+} -result {-justify {} {} left left}
+test config-11.3 {GetConfigList - null default and current value} -constraints {
+ testobjconfig
+} -body {
.a configure -anchor
-} {-anchor anchor Anchor {} {}}
+} -result {-anchor anchor Anchor {} {}}
+if {[testConstraint testobjconfig]} {
+ killTables
+}
+
-deleteWindows
if {[testConstraint testobjconfig]} {
testobjconfig internal .a
}
-test config-12.1 {GetObjectForOption - boolean} testobjconfig {
+test config-12.1 {GetObjectForOption - boolean} -constraints testobjconfig -body {
.a configure -boolean 0
.a cget -boolean
-} {0}
-test config-12.2 {GetObjectForOption - integer} testobjconfig {
+} -result {0}
+test config-12.2 {GetObjectForOption - integer} -constraints testobjconfig -body {
.a configure -integer 1247
.a cget -integer
-} {1247}
-test config-12.3 {GetObjectForOption - double} testobjconfig {
+} -result {1247}
+test config-12.3 {GetObjectForOption - double} -constraints testobjconfig -body {
.a configure -double -88.82
.a cget -double
-} {-88.82}
-test config-12.4 {GetObjectForOption - string} testobjconfig {
+} -result {-88.82}
+test config-12.4 {GetObjectForOption - string} -constraints testobjconfig -body {
.a configure -string "test value"
.a cget -string
-} {test value}
-test config-12.5 {GetObjectForOption - stringTable} testobjconfig {
+} -result {test value}
+test config-12.5 {GetObjectForOption - stringTable} -constraints {
+ testobjconfig
+} -body {
.a configure -stringtable "two"
.a cget -stringtable
-} {two}
-test config-12.6 {GetObjectForOption - color} testobjconfig {
+} -result {two}
+test config-12.6 {GetObjectForOption - color} -constraints testobjconfig -body {
.a configure -color "green"
.a cget -color
-} {green}
-test config-12.7 {GetObjectForOption - font} testobjconfig {
+} -result {green}
+test config-12.7 {GetObjectForOption - font} -constraints testobjconfig -body {
.a configure -font {Times 36}
.a cget -font
-} {Times 36}
-test config-12.8 {GetObjectForOption - bitmap} testobjconfig {
+} -result {Times 36}
+test config-12.8 {GetObjectForOption - bitmap} -constraints testobjconfig -body {
.a configure -bitmap "questhead"
.a cget -bitmap
-} {questhead}
-test config-12.9 {GetObjectForOption - border} testobjconfig {
+} -result {questhead}
+test config-12.9 {GetObjectForOption - border} -constraints testobjconfig -body {
.a configure -border #33217c
.a cget -border
-} {#33217c}
-test config-12.10 {GetObjectForOption - relief} testobjconfig {
+} -result {#33217c}
+test config-12.10 {GetObjectForOption - relief} -constraints {
+ testobjconfig
+} -body {
.a configure -relief groove
.a cget -relief
-} {groove}
-test config-12.11 {GetObjectForOption - cursor} testobjconfig {
+} -result {groove}
+test config-12.11 {GetObjectForOption - cursor} -constraints {
+ testobjconfig
+} -body {
.a configure -cursor watch
.a cget -cursor
-} {watch}
-test config-12.12 {GetObjectForOption - justify} testobjconfig {
+} -result {watch}
+test config-12.12 {GetObjectForOption - justify} -constraints {
+ testobjconfig
+} -body {
.a configure -justify right
.a cget -justify
-} {right}
-test config-12.13 {GetObjectForOption - anchor} testobjconfig {
+} -result {right}
+test config-12.13 {GetObjectForOption - anchor} -constraints testobjconfig -body {
.a configure -anchor e
.a cget -anchor
-} {e}
-test config-12.14 {GetObjectForOption - pixels} testobjconfig {
+} -result {e}
+test config-12.14 {GetObjectForOption - pixels} -constraints testobjconfig -body {
.a configure -pixel 193.2
.a cget -pixel
-} {193}
-test config-12.15 {GetObjectForOption - window} testobjconfig {
+} -result {193}
+test config-12.15 {GetObjectForOption - window} -constraints testobjconfig -body {
.a configure -window .a
.a cget -window
-} {.a}
-test config-12.16 {GetObjectForOption -custom} testobjconfig {
+} -result {.a}
+test config-12.16 {GetObjectForOption -custom} -constraints testobjconfig -body {
.a configure -custom foobar
.a cget -custom
-} {FOOBAR}
-test config-12.17 {GetObjectForOption - null values} testobjconfig {
+} -result {FOOBAR}
+test config-12.17 {GetObjectForOption - null values} -constraints {
+ testobjconfig
+} -body {
.a configure -string {} -color {} -font {} -bitmap {} -border {} \
-cursor {} -window {} -custom {}
list [.a cget -string] [.a cget -color] [.a cget -font] \
[.a cget -bitmap] [.a cget -border] [.a cget -cursor] \
[.a cget -window] [.a cget -custom]
-} {{} {} {} {} {} {} {} {}}
-
-test config-13.1 {proper cleanup of options with widget destroy} {
- foreach type {
- button canvas entry frame listbox menu menubutton message
- scale scrollbar text radiobutton checkbutton
- } {
- destroy .w
- $type .w -cursor crosshair
- destroy .w
- }
-} {}
+} -result {{} {} {} {} {} {} {} {}}
+if {[testConstraint testobjconfig]} {
+ killTables
+}
-deleteWindows
-test config-14.1 {Tk_CreateOptionTable - use with namespace import} {
+test config-13.1 {proper cleanup of options with widget destroy} -body {
+ button .w -cursor crosshair
+ destroy .w
+} -result {}
+test config-13.2 {proper cleanup of options with widget destroy} -body {
+ canvas .w -cursor crosshair
+ destroy .w
+} -result {}
+test config-13.3 {proper cleanup of options with widget destroy} -body {
+ entry .w -cursor crosshair
+ destroy .w
+} -result {}
+test config-13.4 {proper cleanup of options with widget destroy} -body {
+ frame .w -cursor crosshair
+ destroy .w
+} -result {}
+test config-13.5 {proper cleanup of options with widget destroy} -body {
+ listbox .w -cursor crosshair
+ destroy .w
+} -result {}
+test config-13.6 {proper cleanup of options with widget destroy} -body {
+ menu .w -cursor crosshair
+ destroy .w
+} -result {}
+test config-13.7 {proper cleanup of options with widget destroy} -body {
+ menubutton .w -cursor crosshair
+ destroy .w
+} -result {}
+test config-13.8 {proper cleanup of options with widget destroy} -body {
+ message .w -cursor crosshair
+ destroy .w
+} -result {}
+test config-13.9 {proper cleanup of options with widget destroy} -body {
+ scale .w -cursor crosshair
+ destroy .w
+} -result {}
+test config-13.10 {proper cleanup of options with widget destroy} -body {
+ scrollbar .w -cursor crosshair
+ destroy .w
+} -result {}
+test config-13.11 {proper cleanup of options with widget destroy} -body {
+ text .w -cursor crosshair
+ destroy .w
+} -result {}
+test config-13.12 {proper cleanup of options with widget destroy} -body {
+ radiobutton .w -cursor crosshair
+ destroy .w
+} -result {}
+test config-13.13 {proper cleanup of options with widget destroy} -body {
+ checkbutton .w -cursor crosshair
+ destroy .w
+} -result {}
+
+test config-14.1 {Tk_CreateOptionTable - use with namespace import} -setup {
namespace export -clear *
- foreach type {
- button canvas entry frame listbox menu menubutton message
- scale scrollbar spinbox text radiobutton checkbutton
- } {
- namespace eval ::foo [subst {
- namespace import -force ::$type
- ::foo::$type .a
- ::foo::$type .b
- }
- ]
- destroy .a .b
- }
-} {}
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::button
+ ::foo::button .a
+ ::foo::button .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+test config-14.2 {Tk_CreateOptionTable - use with namespace import} -setup {
+ namespace export -clear *
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::canvas
+ ::foo::canvas .a
+ ::foo::canvas .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+test config-14.3 {Tk_CreateOptionTable - use with namespace import} -setup {
+ namespace export -clear *
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::entry
+ ::foo::entry .a
+ ::foo::entry .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+test config-14.4 {Tk_CreateOptionTable - use with namespace import} -setup {
+ namespace export -clear *
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::frame
+ ::foo::frame .a
+ ::foo::frame .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+test config-14.5 {Tk_CreateOptionTable - use with namespace import} -setup {
+ namespace export -clear *
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::listbox
+ ::foo::listbox .a
+ ::foo::listbox .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+test config-14.6 {Tk_CreateOptionTable - use with namespace import} -setup {
+ namespace export -clear *
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::menu
+ ::foo::menu .a
+ ::foo::menu .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+test config-14.7 {Tk_CreateOptionTable - use with namespace import} -setup {
+ namespace export -clear *
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::menubutton
+ ::foo::menubutton .a
+ ::foo::menubutton .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+test config-14.8 {Tk_CreateOptionTable - use with namespace import} -setup {
+ namespace export -clear *
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::message
+ ::foo::message .a
+ ::foo::message .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+test config-14.9 {Tk_CreateOptionTable - use with namespace import} -setup {
+ namespace export -clear *
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::scale
+ ::foo::scale .a
+ ::foo::scale .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+test config-14.10 {Tk_CreateOptionTable - use with namespace import} -setup {
+ namespace export -clear *
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::scrollbar
+ ::foo::scrollbar .a
+ ::foo::scrollbar .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+test config-14.11 {Tk_CreateOptionTable - use with namespace import} -setup {
+ namespace export -clear *
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::spinbox
+ ::foo::spinbox .a
+ ::foo::spinbox .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+test config-14.12 {Tk_CreateOptionTable - use with namespace import} -setup {
+ namespace export -clear *
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::text
+ ::foo::text .a
+ ::foo::text .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+test config-14.13 {Tk_CreateOptionTable - use with namespace import} -setup {
+ namespace export -clear *
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::radiobutton
+ ::foo::radiobutton .a
+ ::foo::radiobutton .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+test config-14.14 {Tk_CreateOptionTable - use with namespace import} -setup {
+ namespace export -clear *
+} -body {
+ namespace eval ::foo [subst {
+ namespace import -force ::checkbutton
+ ::foo::checkbutton .a
+ ::foo::checkbutton .b
+ }
+ ]
+ destroy .a .b
+} -result {}
+
# cleanup
deleteWindows
@@ -888,3 +1919,11 @@ if {[testConstraint testobjconfig]} {
}
cleanupTests
return
+
+
+
+
+
+
+
+
diff --git a/tests/constraints.tcl b/tests/constraints.tcl
index bc2c09b..e28b159 100644
--- a/tests/constraints.tcl
+++ b/tests/constraints.tcl
@@ -138,6 +138,42 @@ namespace eval tk {
focus -force .focus.e
destroy .focus
}
+
+
+ namespace export imageInit imageFinish imageCleanup imageNames
+ variable ImageNames
+ proc imageInit {} {
+ variable ImageNames
+ if {![info exists ImageNames]} {
+ set ImageNames [lsort [image names]]
+ }
+ imageCleanup
+ if {[lsort [image names]] ne $ImageNames} {
+ return -code error "IMAGE NAMES mismatch: [image names] != $ImageNames"
+ }
+ }
+ proc imageFinish {} {
+ variable ImageNames
+ if {[lsort [image names]] ne $ImageNames} {
+ return -code error "images remaining: [image names] != $ImageNames"
+ }
+ imageCleanup
+ }
+ proc imageCleanup {} {
+ variable ImageNames
+ foreach img [image names] {
+ if {$img ni $ImageNames} {image delete $img}
+ }
+ }
+ proc imageNames {} {
+ variable ImageNames
+ set r {}
+ foreach img [image names] {
+ if {$img ni $ImageNames} {lappend r $img}
+ }
+ return $r
+ }
+
}
}
@@ -182,7 +218,7 @@ testConstraint testwrapper [llength [info commands testwrapper]]
# constraint to see what sort of fonts are available
testConstraint fonts 1
destroy .e
-entry .e -width 0 -font {Helvetica -12} -bd 1
+entry .e -width 0 -font {Helvetica -12} -bd 1 -highlightthickness 1
.e insert end a.bcd
if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} {
testConstraint fonts 0
@@ -242,7 +278,6 @@ namespace import -force tcltest::removeDirectory
namespace import -force tcltest::interpreter
namespace import -force tcltest::testsDirectory
namespace import -force tcltest::cleanupTests
-namespace import -force tcltest::bytestring
deleteWindows
wm geometry . {}
diff --git a/tests/cursor.test b/tests/cursor.test
index 539e933..1039b52 100644
--- a/tests/cursor.test
+++ b/tests/cursor.test
@@ -6,96 +6,133 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
-test cursor-1.1 {Tk_AllocCursorFromObj - converting internal reps} {testcursor} {
+
+# Tests 2.3 and 2.4 need a helper file with a very specific name and
+# controlled format.
+proc setWincur {wincurName} {
+ upvar $wincurName wincur
+ set wincur(data_octal) {
+ 000 000 002 000 001 000 040 040 000 000 007 000 007 000 060 001
+ 000 000 026 000 000 000 050 000 000 000 040 000 000 000 100 000
+ 000 000 001 000 001 000 000 000 000 000 000 000 000 000 000 000
+ 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
+ 000 000 377 377 377 000 000 000 000 000 000 000 000 000 000 000
+ 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
+ 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
+ 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
+ 000 000 000 000 000 000 000 000 000 000 160 016 000 000 170 036
+ 000 000 174 076 000 000 076 174 000 000 037 370 000 000 017 360
+ 000 000 007 340 000 000 007 340 000 000 017 360 000 000 037 370
+ 000 000 076 174 000 000 174 076 000 000 170 036 000 000 160 016
+ 000 000 000 000 000 000 377 377 377 377 377 377 377 377 377 377
+ 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377
+ 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377
+ 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377
+ 377 377 377 377 377 377 017 360 377 377 007 340 377 377 003 300
+ 377 377 001 200 377 377 200 001 377 377 300 003 377 377 340 007
+ 377 377 360 017 377 377 360 017 377 377 340 007 377 377 300 003
+ 377 377 200 001 377 377 001 200 377 377 003 300 377 377 007 340
+ 377 377 017 360 377 377
+ }
+ set wincur(data_binary) {}
+ foreach wincur(num) $wincur(data_octal) {
+ append wincur(data_binary) [binary format c [scan $wincur(num) %o]]
+ }
+ set wincur(dir) [makeDirectory {dir with spaces}]
+ set wincur(file) [makeFile $wincur(data_binary) "test file.cur" $wincur(dir)]
+}
+
+
+test cursor-1.1 {Tk_AllocCursorFromObj - converting internal reps} -constraints {
+ testcursor
+} -body {
set x watch
lindex $x 0
- destroy .b1
- button .b1 -cursor $x
+ button .b -cursor $x
lindex $x 0
testcursor watch
-} {{1 0}}
-test cursor-1.2 {Tk_AllocCursorFromObj - discard stale cursor} {testcursor} {
+} -cleanup {
+ destroy .b
+} -result {{1 0}}
+test cursor-1.2 {Tk_AllocCursorFromObj - discard stale cursor} -constraints {
+ testcursor
+} -body {
set x watch
- destroy .b1 .b2
+ set result {}
button .b1 -cursor $x
destroy .b1
- set result {}
lappend result [testcursor watch]
button .b2 -cursor $x
lappend result [testcursor watch]
-} {{} {{1 1}}}
-test cursor-1.3 {Tk_AllocCursorFromObj - reuse existing cursor} {testcursor} {
+} -cleanup {
+ destroy .b2
+} -result {{} {{1 1}}}
+test cursor-1.3 {Tk_AllocCursorFromObj - reuse existing cursor} -constraints {
+ testcursor
+} -body {
set x watch
- destroy .b1 .b2
- button .b1 -cursor $x
set result {}
+ button .b1 -cursor $x
lappend result [testcursor watch]
button .b2 -cursor $x
pack .b1 .b2 -side top
lappend result [testcursor watch]
-} {{{1 1}} {{2 1}}}
+} -cleanup {
+ destroy .b1 .b2
+} -result {{{1 1}} {{2 1}}}
-test cursor-2.1 {Tk_GetCursor procedure} {
- destroy .b1
- list [catch {button .b1 -cursor bad_name} msg] $msg
-} {1 {bad cursor spec "bad_name"}}
-test cursor-2.2 {Tk_GetCursor procedure} {
- destroy .b1
- list [catch {button .b1 -cursor @xyzzy} msg] $msg
-} {1 {bad cursor spec "@xyzzy"}}
-# Next two tests need a helper file with a very specific name and
-# controlled format.
-set wincur(data_octal) {
- 000 000 002 000 001 000 040 040 000 000 007 000 007 000 060 001
- 000 000 026 000 000 000 050 000 000 000 040 000 000 000 100 000
- 000 000 001 000 001 000 000 000 000 000 000 000 000 000 000 000
- 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
- 000 000 377 377 377 000 000 000 000 000 000 000 000 000 000 000
- 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
- 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
- 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
- 000 000 000 000 000 000 000 000 000 000 160 016 000 000 170 036
- 000 000 174 076 000 000 076 174 000 000 037 370 000 000 017 360
- 000 000 007 340 000 000 007 340 000 000 017 360 000 000 037 370
- 000 000 076 174 000 000 174 076 000 000 170 036 000 000 160 016
- 000 000 000 000 000 000 377 377 377 377 377 377 377 377 377 377
- 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377
- 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377
- 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377
- 377 377 377 377 377 377 017 360 377 377 007 340 377 377 003 300
- 377 377 001 200 377 377 200 001 377 377 300 003 377 377 340 007
- 377 377 360 017 377 377 360 017 377 377 340 007 377 377 300 003
- 377 377 200 001 377 377 001 200 377 377 003 300 377 377 007 340
- 377 377 017 360 377 377
-}
-set wincur(data_binary) {}
-foreach wincur(num) $wincur(data_octal) {
- append wincur(data_binary) [binary format c [scan $wincur(num) %o]]
-}
-set wincur(dir) [makeDirectory {dir with spaces}]
-set wincur(file) [makeFile $wincur(data_binary) "test file.cur" $wincur(dir)]
-test cursor-2.3 {Tk_GetCursor procedure: cursor specs are lists} win {
- destroy .b1
- button .b1 -cursor [list @$wincur(file)]
-} {.b1}
-test cursor-2.4 {Tk_GetCursor procedure: cursor specs are lists} win {
- destroy .b1
- button .b1 -cursor @[regsub -all {[][ \\{}""$#]} $wincur(file) {\\&}]
-} {.b1}
-removeDirectory $wincur(dir)
-unset wincur
+test cursor-2.1 {Tk_GetCursor procedure} -body {
+ button .b -cursor bad_name
+} -cleanup {
+ destroy .b
+} -returnCodes error -result {bad cursor spec "bad_name"}
+test cursor-2.2 {Tk_GetCursor procedure} -body {
+ button .b -cursor @xyzzy
+} -cleanup {
+ destroy .b
+} -returnCodes error -result {bad cursor spec "@xyzzy"}
-test cursor-3.1 {Tk_FreeCursorFromObj - reference counts} {testcursor} {
+test cursor-2.3 {Tk_GetCursor procedure: cursor specs are lists} -constraints {
+ win
+} -setup {
+ unset -nocomplain wincur
+ set wincur(file) ""
+} -body {
+ setWincur wincur
+ button .b -cursor [list @$wincur(file)]
+} -cleanup {
+ destroy .b
+ removeDirectory $wincur(dir)
+ unset wincur
+} -result {.b}
+test cursor-2.4 {Tk_GetCursor procedure: cursor specs are lists} -constraints {
+ win
+} -setup {
+ unset -nocomplain wincur
+ set wincur(file) ""
+} -body {
+ setWincur wincur
+ button .b -cursor @[regsub -all {[][ \\{}""$#]} $wincur(file) {\\&}]
+} -cleanup {
+ destroy .b
+ removeDirectory $wincur(dir)
+ unset wincur
+} -result {.b}
+
+test cursor-3.1 {Tk_FreeCursorFromObj - reference counts} -constraints {
+ testcursor
+} -setup {
set x heart
- destroy .b1 .b2 .b3
+ set result {}
+} -body {
button .b1 -cursor $x
button .b3 -cursor $x
button .b2 -cursor $x
- set result {}
lappend result [testcursor heart]
destroy .b1
lappend result [testcursor heart]
@@ -103,10 +140,11 @@ test cursor-3.1 {Tk_FreeCursorFromObj - reference counts} {testcursor} {
lappend result [testcursor heart]
destroy .b3
lappend result [testcursor heart]
-} {{{3 1}} {{2 1}} {{1 1}} {}}
+} -result {{{3 1}} {{2 1}} {{1 1}} {}}
-test cursor-4.1 {FreeCursorObjProc} {testcursor} {
- destroy .b
+test cursor-4.1 {FreeCursorObjProc} -constraints {
+ testcursor
+} -body {
set x [format heart]
button .b -cursor $x
set y [format heart]
@@ -123,10 +161,11 @@ test cursor-4.1 {FreeCursorObjProc} {testcursor} {
lappend result [testcursor heart]
set y bogus
set result
-} {{{1 3}} {{1 2}} {{1 1}} {}}
+} -cleanup {
+ destroy .b
+} -result {{{1 3}} {{1 2}} {{1 1}} {}}
# -------------------------------------------------------------------------
-
test cursor-5.1 {assert consistent cursor configuration command} -setup {
button .b
} -body {
@@ -137,101 +176,551 @@ test cursor-5.1 {assert consistent cursor configuration command} -setup {
# -------------------------------------------------------------------------
# Check for the standard set of cursors.
-
-foreach {testName cursor} {
- cursor-6.1 X_cursor
- cursor-6.2 arrow
- cursor-6.3 based_arrow_down
- cursor-6.4 based_arrow_up
- cursor-6.5 boat
- cursor-6.6 bogosity
- cursor-6.7 bottom_left_corner
- cursor-6.8 bottom_right_corner
- cursor-6.9 bottom_side
- cursor-6.10 bottom_tee
- cursor-6.11 box_spiral
- cursor-6.12 center_ptr
- cursor-6.13 circle
- cursor-6.14 clock
- cursor-6.15 coffee_mug
- cursor-6.16 cross
- cursor-6.17 cross_reverse
- cursor-6.18 crosshair
- cursor-6.19 diamond_cross
- cursor-6.20 dot
- cursor-6.21 dotbox
- cursor-6.22 double_arrow
- cursor-6.23 draft_large
- cursor-6.24 draft_small
- cursor-6.25 draped_box
- cursor-6.26 exchange
- cursor-6.27 fleur
- cursor-6.28 gobbler
- cursor-6.29 gumby
- cursor-6.30 hand1
- cursor-6.31 hand2
- cursor-6.32 heart
- cursor-6.33 icon
- cursor-6.34 iron_cross
- cursor-6.35 left_ptr
- cursor-6.36 left_side
- cursor-6.37 left_tee
- cursor-6.38 leftbutton
- cursor-6.39 ll_angle
- cursor-6.40 lr_angle
- cursor-6.41 man
- cursor-6.42 middlebutton
- cursor-6.43 mouse
- cursor-6.44 pencil
- cursor-6.45 pirate
- cursor-6.46 plus
- cursor-6.47 question_arrow
- cursor-6.48 right_ptr
- cursor-6.49 right_side
- cursor-6.50 right_tee
- cursor-6.51 rightbutton
- cursor-6.52 rtl_logo
- cursor-6.53 sailboat
- cursor-6.54 sb_down_arrow
- cursor-6.55 sb_h_double_arrow
- cursor-6.56 sb_left_arrow
- cursor-6.57 sb_right_arrow
- cursor-6.58 sb_up_arrow
- cursor-6.59 sb_v_double_arrow
- cursor-6.60 shuttle
- cursor-6.61 sizing
- cursor-6.62 spider
- cursor-6.63 spraycan
- cursor-6.64 star
- cursor-6.65 target
- cursor-6.66 tcross
- cursor-6.67 top_left_arrow
- cursor-6.68 top_left_corner
- cursor-6.69 top_right_corner
- cursor-6.70 top_side
- cursor-6.71 top_tee
- cursor-6.72 trek
- cursor-6.73 ul_angle
- cursor-6.74 umbrella
- cursor-6.75 ur_angle
- cursor-6.76 watch
- cursor-6.77 xterm
-} {
- test $testName "check cursor-font cursor $cursor" -setup {
- button .b -text $cursor
- } -body {
- .b configure -cursor $cursor
- } -cleanup {
- destroy .b
- } -result {}
-}
+test cursor-6.1 {check cursor-font cursor X_cursor} -setup {
+ button .b -text X_cursor
+} -body {
+ .b configure -cursor X_cursor
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.2 {check cursor-font cursor arrow} -setup {
+ button .b -text arrow
+} -body {
+ .b configure -cursor arrow
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.3 {check cursor-font cursor based_arrow_down} -setup {
+ button .b -text based_arrow_down
+} -body {
+ .b configure -cursor based_arrow_down
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.4 {check cursor-font cursor based_arrow_up} -setup {
+ button .b -text based_arrow_up
+} -body {
+ .b configure -cursor based_arrow_up
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.5 {check cursor-font cursor boat} -setup {
+ button .b -text boat
+} -body {
+ .b configure -cursor boat
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.6 {check cursor-font cursor bogosity} -setup {
+ button .b -text bogosity
+} -body {
+ .b configure -cursor bogosity
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.7 {check cursor-font cursor bottom_left_corner} -setup {
+ button .b -text bottom_left_corner
+} -body {
+ .b configure -cursor bottom_left_corner
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.8 {check cursor-font cursor bottom_right_corner} -setup {
+ button .b -text bottom_right_corner
+} -body {
+ .b configure -cursor bottom_right_corner
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.9 {check cursor-font cursor bottom_side} -setup {
+ button .b -text bottom_side
+} -body {
+ .b configure -cursor bottom_side
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.10 {check cursor-font cursor bottom_tee} -setup {
+ button .b -text bottom_tee
+} -body {
+ .b configure -cursor bottom_tee
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.11 {check cursor-font cursor box_spiral} -setup {
+ button .b -text box_spiral
+} -body {
+ .b configure -cursor box_spiral
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.12 {check cursor-font cursor center_ptr} -setup {
+ button .b -text center_ptr
+} -body {
+ .b configure -cursor center_ptr
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.13 {check cursor-font cursor circle} -setup {
+ button .b -text circle
+} -body {
+ .b configure -cursor circle
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.14 {check cursor-font cursor clock} -setup {
+ button .b -text clock
+} -body {
+ .b configure -cursor clock
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.15 {check cursor-font cursor coffee_mug} -setup {
+ button .b -text coffee_mug
+} -body {
+ .b configure -cursor coffee_mug
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.16 {check cursor-font cursor cross} -setup {
+ button .b -text cross
+} -body {
+ .b configure -cursor cross
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.17 {check cursor-font cursor cross_reverse} -setup {
+ button .b -text cross_reverse
+} -body {
+ .b configure -cursor cross_reverse
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.18 {check cursor-font cursor crosshair} -setup {
+ button .b -text crosshair
+} -body {
+ .b configure -cursor crosshair
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.19 {check cursor-font cursor diamond_cross} -setup {
+ button .b -text diamond_cross
+} -body {
+ .b configure -cursor diamond_cross
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.20 {check cursor-font cursor dot} -setup {
+ button .b -text dot
+} -body {
+ .b configure -cursor dot
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.21 {check cursor-font cursor dotbox} -setup {
+ button .b -text dotbox
+} -body {
+ .b configure -cursor dotbox
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.22 {check cursor-font cursor double_arrow} -setup {
+ button .b -text double_arrow
+} -body {
+ .b configure -cursor double_arrow
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.23 {check cursor-font cursor draft_large} -setup {
+ button .b -text draft_large
+} -body {
+ .b configure -cursor draft_large
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.24 {check cursor-font cursor draft_small} -setup {
+ button .b -text draft_small
+} -body {
+ .b configure -cursor draft_small
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.25 {check cursor-font cursor draped_box} -setup {
+ button .b -text draped_box
+} -body {
+ .b configure -cursor draped_box
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.26 {check cursor-font cursor exchange} -setup {
+ button .b -text exchange
+} -body {
+ .b configure -cursor exchange
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.27 {check cursor-font cursor fleur} -setup {
+ button .b -text fleur
+} -body {
+ .b configure -cursor fleur
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.28 {check cursor-font cursor gobbler} -setup {
+ button .b -text gobbler
+} -body {
+ .b configure -cursor gobbler
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.29 {check cursor-font cursor gumby} -setup {
+ button .b -text gumby
+} -body {
+ .b configure -cursor gumby
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.30 {check cursor-font cursor hand1} -setup {
+ button .b -text hand1
+} -body {
+ .b configure -cursor hand1
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.31 {check cursor-font cursor hand2} -setup {
+ button .b -text hand2
+} -body {
+ .b configure -cursor hand2
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.32 {check cursor-font cursor heart} -setup {
+ button .b -text heart
+} -body {
+ .b configure -cursor heart
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.33 {check cursor-font cursor icon} -setup {
+ button .b -text icon
+} -body {
+ .b configure -cursor icon
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.34 {check cursor-font cursor iron_cross} -setup {
+ button .b -text iron_cross
+} -body {
+ .b configure -cursor iron_cross
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.35 {check cursor-font cursor left_ptr} -setup {
+ button .b -text left_ptr
+} -body {
+ .b configure -cursor left_ptr
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.36 {check cursor-font cursor left_side} -setup {
+ button .b -text left_side
+} -body {
+ .b configure -cursor left_side
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.37 {check cursor-font cursor left_tee} -setup {
+ button .b -text left_tee
+} -body {
+ .b configure -cursor left_tee
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.38 {check cursor-font cursor leftbutton} -setup {
+ button .b -text leftbutton
+} -body {
+ .b configure -cursor leftbutton
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.39 {check cursor-font cursor ll_angle} -setup {
+ button .b -text ll_angle
+} -body {
+ .b configure -cursor ll_angle
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.40 {check cursor-font cursor lr_angle} -setup {
+ button .b -text lr_angle
+} -body {
+ .b configure -cursor lr_angle
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.41 {check cursor-font cursor man} -setup {
+ button .b -text man
+} -body {
+ .b configure -cursor man
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.42 {check cursor-font cursor middlebutton} -setup {
+ button .b -text middlebutton
+} -body {
+ .b configure -cursor middlebutton
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.43 {check cursor-font cursor mouse} -setup {
+ button .b -text mouse
+} -body {
+ .b configure -cursor mouse
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.44 {check cursor-font cursor pencil} -setup {
+ button .b -text pencil
+} -body {
+ .b configure -cursor pencil
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.45 {check cursor-font cursor pirate} -setup {
+ button .b -text pirate
+} -body {
+ .b configure -cursor pirate
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.46 {check cursor-font cursor plus} -setup {
+ button .b -text plus
+} -body {
+ .b configure -cursor plus
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.47 {check cursor-font cursor question_arrow} -setup {
+ button .b -text question_arrow
+} -body {
+ .b configure -cursor question_arrow
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.48 {check cursor-font cursor right_ptr} -setup {
+ button .b -text right_ptr
+} -body {
+ .b configure -cursor right_ptr
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.49 {check cursor-font cursor right_side} -setup {
+ button .b -text right_side
+} -body {
+ .b configure -cursor right_side
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.50 {check cursor-font cursor right_tee} -setup {
+ button .b -text right_tee
+} -body {
+ .b configure -cursor right_tee
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.51 {check cursor-font cursor rightbutton} -setup {
+ button .b -text rightbutton
+} -body {
+ .b configure -cursor rightbutton
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.52 {check cursor-font cursor rtl_logo} -setup {
+ button .b -text rtl_logo
+} -body {
+ .b configure -cursor rtl_logo
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.53 {check cursor-font cursor sailboat} -setup {
+ button .b -text sailboat
+} -body {
+ .b configure -cursor sailboat
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.54 {check cursor-font cursor sb_down_arrow} -setup {
+ button .b -text sb_down_arrow
+} -body {
+ .b configure -cursor sb_down_arrow
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.55 {check cursor-font cursor sb_h_double_arrow} -setup {
+ button .b -text sb_h_double_arrow
+} -body {
+ .b configure -cursor sb_h_double_arrow
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.56 {check cursor-font cursor sb_left_arrow} -setup {
+ button .b -text sb_left_arrow
+} -body {
+ .b configure -cursor sb_left_arrow
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.57 {check cursor-font cursor sb_right_arrow} -setup {
+ button .b -text sb_right_arrow
+} -body {
+ .b configure -cursor sb_right_arrow
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.58 {check cursor-font cursor sb_up_arrow} -setup {
+ button .b -text sb_up_arrow
+} -body {
+ .b configure -cursor sb_up_arrow
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.59 {check cursor-font cursor sb_v_double_arrow} -setup {
+ button .b -text sb_v_double_arrow
+} -body {
+ .b configure -cursor sb_v_double_arrow
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.60 {check cursor-font cursor shuttle} -setup {
+ button .b -text shuttle
+} -body {
+ .b configure -cursor shuttle
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.61 {check cursor-font cursor sizing} -setup {
+ button .b -text sizing
+} -body {
+ .b configure -cursor sizing
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.62 {check cursor-font cursor spider} -setup {
+ button .b -text spider
+} -body {
+ .b configure -cursor spider
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.63 {check cursor-font cursor spraycan} -setup {
+ button .b -text spraycan
+} -body {
+ .b configure -cursor spraycan
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.64 {check cursor-font cursor star} -setup {
+ button .b -text star
+} -body {
+ .b configure -cursor star
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.65 {check cursor-font cursor target} -setup {
+ button .b -text target
+} -body {
+ .b configure -cursor target
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.66 {check cursor-font cursor tcross} -setup {
+ button .b -text tcross
+} -body {
+ .b configure -cursor tcross
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.67 {check cursor-font cursor top_left_arrow} -setup {
+ button .b -text top_left_arrow
+} -body {
+ .b configure -cursor top_left_arrow
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.68 {check cursor-font cursor top_left_corner} -setup {
+ button .b -text top_left_corner
+} -body {
+ .b configure -cursor top_left_corner
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.69 {check cursor-font cursor top_right_corner} -setup {
+ button .b -text top_right_corner
+} -body {
+ .b configure -cursor top_right_corner
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.70 {check cursor-font cursor top_side} -setup {
+ button .b -text top_side
+} -body {
+ .b configure -cursor top_side
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.71 {check cursor-font cursor top_tee} -setup {
+ button .b -text top_tee
+} -body {
+ .b configure -cursor top_tee
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.72 {check cursor-font cursor trek} -setup {
+ button .b -text trek
+} -body {
+ .b configure -cursor trek
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.73 {check cursor-font cursor ul_angle} -setup {
+ button .b -text ul_angle
+} -body {
+ .b configure -cursor ul_angle
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.74 {check cursor-font cursor umbrella} -setup {
+ button .b -text umbrella
+} -body {
+ .b configure -cursor umbrella
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.75 {check cursor-font cursor ur_angle} -setup {
+ button .b -text ur_angle
+} -body {
+ .b configure -cursor ur_angle
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.76 {check cursor-font cursor watch} -setup {
+ button .b -text watch
+} -body {
+ .b configure -cursor watch
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-6.77 {check cursor-font cursor xterm} -setup {
+ button .b -text xterm
+} -body {
+ .b configure -cursor xterm
+} -cleanup {
+ destroy .b
+} -result {}
# Test cursor named "none", it is not defined in
# the X cursor table. It is defined in a Tk specific
# table of named cursors and should be available on
# all platforms.
-
-test cursor-6.80 {} -setup {
+test cursor-6.78 {test cursor named "none"} -setup {
button .b -text CButton
} -body {
.b configure -cursor none
@@ -240,7 +729,7 @@ test cursor-6.80 {} -setup {
destroy .b
} -result none
-test cursor-6.81 {} -setup {
+test cursor-6.79 {test cursor named "none"} -setup {
button .b -text CButton
} -body {
.b configure -cursor none
@@ -250,7 +739,7 @@ test cursor-6.81 {} -setup {
destroy .b
} -result {}
-test cursor-6.82 {} -setup {
+test cursor-6.80 {test cursor named "none"} -setup {
button .b -text CButton
} -body {
.b configure -cursor none
@@ -261,7 +750,7 @@ test cursor-6.82 {} -setup {
destroy .b
} -result none
-test cursor-6.83 {} -setup {
+test cursor-6.81 {test cursor named "none"} -setup {
button .b -text CButton
} -body {
# Setting fg and bg does nothing for the none cursor
@@ -283,31 +772,72 @@ test cursor-6.83 {} -setup {
# -------------------------------------------------------------------------
# Check the Windows specific cursors
-
-foreach {testName cursor} {
- cursor-7.1 no
- cursor-7.2 starting
- cursor-7.3 size
- cursor-7.4 size_ne_sw
- cursor-7.5 size_ns
- cursor-7.6 size_nw_se
- cursor-7.7 size_we
- cursor-7.8 uparrow
- cursor-7.9 wait
-} {
- test $testName "check Windows cursor $cursor" -constraints win -setup {
- button .b -text $cursor
- } -body {
- .b configure -cursor $cursor
- } -cleanup {
- destroy .b
- } -result {}
-}
+test cursor-7.1 {check Windows cursor no} -constraints win -setup {
+ button .b -text no
+} -body {
+ .b configure -cursor no
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-7.2 {check Windows cursor starting} -constraints win -setup {
+ button .b -text starting
+} -body {
+ .b configure -cursor starting
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-7.3 {check Windows cursor size} -constraints win -setup {
+ button .b -text size
+} -body {
+ .b configure -cursor size
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-7.4 {check Windows cursor size_ne_sw} -constraints win -setup {
+ button .b -text size_ne_sw
+} -body {
+ .b configure -cursor size_ne_sw
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-7.5 {check Windows cursor size_ns} -constraints win -setup {
+ button .b -text size_ns
+} -body {
+ .b configure -cursor size_ns
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-7.6 {check Windows cursor size_nw_se} -constraints win -setup {
+ button .b -text size_nw_se
+} -body {
+ .b configure -cursor size_nw_se
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-7.7 {check Windows cursor size_we} -constraints win -setup {
+ button .b -text size_we
+} -body {
+ .b configure -cursor size_we
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-7.8 {check Windows cursor uparrow} -constraints win -setup {
+ button .b -text uparrow
+} -body {
+ .b configure -cursor uparrow
+} -cleanup {
+ destroy .b
+} -result {}
+test cursor-7.9 {check Windows cursor wait} -constraints win -setup {
+ button .b -text wait
+} -body {
+ .b configure -cursor wait
+} -cleanup {
+ destroy .b
+} -result {}
# -------------------------------------------------------------------------
-destroy .t
-
# cleanup
cleanupTests
return
diff --git a/tests/dialog.test b/tests/dialog.test
index 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 ffdbf45..11408ac 100644
--- a/tests/entry.test
+++ b/tests/entry.test
@@ -6,221 +6,880 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
+# For xscrollcommand
proc scroll args {
- global scrollInfo
- set scrollInfo $args
+ global scrollInfo
+ set scrollInfo $args
+}
+# For trace variable
+proc override args {
+ global x
+ set x 12345
}
-# Create additional widget that's used to hold the selection at times.
-
-entry .sel
-.sel insert end "This is some sample text"
-
-# Font names
-
-set big -adobe-helvetica-medium-r-normal--24-240-75-75-p-*-iso8859-1
-set fixed -adobe-courier-medium-r-normal--12-120-75-75-m-*-iso8859-1
-
-# Create entries in the option database to be sure that geometry options
-# like border width have predictable values.
-
-option add *Entry.borderWidth 2
-option add *Entry.highlightThickness 2
-option add *Entry.font {Helvetica -12}
-
-entry .e -bd 2 -relief sunken
-pack .e
-update
-
-set i 1
-foreach test {
- {-background #ff0000 #ff0000 non-existent
- {unknown color name "non-existent"}}
- {-bd 4 4 badValue {bad screen distance "badValue"}}
- {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}}
- {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
- {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
- {-disabledbackground green green non-existent
- {unknown color name "non-existent"}}
- {-disabledforeground blue blue non-existent
- {unknown color name "non-existent"}}
- {-exportselection yes 1 xyzzy {expected boolean value but got "xyzzy"}}
- {-fg #110022 #110022 bogus {unknown color name "bogus"}}
- {-font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
- -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* {}
- {font "" doesn't exist}}
- {-foreground #110022 #110022 bogus {unknown color name "bogus"}}
- {-highlightbackground #123456 #123456 ugly {unknown color name "ugly"}}
- {-highlightcolor #123456 #123456 bogus {unknown color name "bogus"}}
- {-highlightthickness 6 6 bogus {bad screen distance "bogus"}}
- {-highlightthickness -2 0 {} {}}
- {-insertbackground #110022 #110022 bogus {unknown color name "bogus"}}
- {-insertborderwidth 1.3 1 2.6x {bad screen distance "2.6x"}}
- {-insertofftime 100 100 3.2 {expected integer but got "3.2"}}
- {-insertontime 100 100 3.2 {expected integer but got "3.2"}}
- {-invalidcommand "any string" "any string" {} {}}
- {-invcmd "any string" "any string" {} {}}
- {-justify right right bogus {bad justification "bogus": must be left, right, or center}}
- {-readonlybackground green green non-existent
- {unknown color name "non-existent"}}
- {-relief groove groove 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}}
- {-selectbackground #110022 #110022 bogus {unknown color name "bogus"}}
- {-selectborderwidth 1.3 1 badValue {bad screen distance "badValue"}}
- {-selectforeground #654321 #654321 bogus {unknown color name "bogus"}}
- {-show * * {} {}}
- {-state n normal bogus
- {bad state "bogus": must be disabled, normal, or readonly}}
- {-takefocus "any string" "any string" {} {}}
- {-textvariable i i {} {}}
- {-width 402 402 3p {expected integer but got "3p"}}
- {-xscrollcommand {Some command} {Some command} {} {}}
-} {
- lassign $test name goodValue goodResult badValue badResult
- test entry-1.$i {configuration options} {
- .e configure $name $goodValue
- list [lindex [.e configure $name] 4] [.e cget $name]
- } [list $goodResult $goodResult]
- incr i
- if {$badValue ne ""} {
- test entry-1.$i {configuration options} -body {
- .e configure $name $badValue
- } -returnCodes error -result $badResult
- }
- .e configure $name [lindex [.e configure $name] 3]
- incr i
+# Procedures used in widget VALIDATION tests
+proc doval {W d i P s S v V} {
+ set ::vVals [list $W $d $i $P $s $S $v $V]
+ return 1
+}
+proc doval2 {W d i P s S v V} {
+ set ::vVals [list $W $d $i $P $s $S $v $V]
+ set ::e mydata
+ return 1
+}
+proc doval3 {W d i P s S v V} {
+ set ::vVals [list $W $d $i $P $s $S $v $V]
+ return 0
}
-test entry-2.1 {Tk_EntryCmd procedure} {
- list [catch {entry} msg] $msg
-} {1 {wrong # args: should be "entry pathName ?options?"}}
-test entry-2.2 {Tk_EntryCmd procedure} {
- list [catch {entry gorp} msg] $msg
-} {1 {bad window path name "gorp"}}
-test entry-2.3 {Tk_EntryCmd procedure} {
- catch {destroy .e}
+set cy [font metrics {Courier -12} -linespace]
+
+
+test entry-1.1 {configuration option: "background" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -background #ff0000
+ .e cget -background
+} -cleanup {
+ destroy .e
+} -result {#ff0000}
+test entry-1.2 {configuration option: "background" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -background non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test entry-1.3 {configuration option: "bd" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -bd 4
+ .e cget -bd
+} -cleanup {
+ destroy .e
+} -result {4}
+test entry-1.4 {configuration option: "bd" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -bd badValue
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+test entry-1.5 {configuration option: "bg" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -bg #ff0000
+ .e cget -bg
+} -cleanup {
+ destroy .e
+} -result {#ff0000}
+test entry-1.6 {configuration option: "bg" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -bg non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test entry-1.7 {configuration option: "borderwidth" for entry} -setup {
+ entry .e -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -borderwidth 1.3
+ .e cget -borderwidth
+} -cleanup {
+ destroy .e
+} -result {1}
+test entry-1.8 {configuration option: "borderwidth" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -borderwidth badValue
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+test entry-1.9 {configuration option: "cursor" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -cursor arrow
+ .e cget -cursor
+} -cleanup {
+ destroy .e
+} -result {arrow}
+test entry-1.10 {configuration option: "cursor" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -cursor badValue
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad cursor spec "badValue"}
+
+test entry-1.11 {configuration option: "disabledbackground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -disabledbackground green
+ .e cget -disabledbackground
+} -cleanup {
+ destroy .e
+} -result {green}
+test entry-1.12 {configuration option: "disabledbackground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -disabledbackground non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test entry-1.13 {configuration option: "disabledforeground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -disabledforeground blue
+ .e cget -disabledforeground
+} -cleanup {
+ destroy .e
+} -result {blue}
+test entry-1.14 {configuration option: "disabledforeground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -disabledforeground non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test entry-1.15 {configuration option: "exportselection" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -exportselection yes
+ .e cget -exportselection
+} -cleanup {
+ destroy .e
+} -result {1}
+test entry-1.16 {configuration option: "exportselection" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -exportselection xyzzy
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected boolean value but got "xyzzy"}
+
+test entry-1.17 {configuration option: "fg" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -fg #110022
+ .e cget -fg
+} -cleanup {
+ destroy .e
+} -result {#110022}
+test entry-1.18 {configuration option: "fg" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -fg non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test entry-1.19 {configuration option: "font" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e configure -font {Helvetica -12}
+ .e cget -font
+} -cleanup {
+ destroy .e
+} -result {Helvetica -12}
+test entry-1.20 {configuration option: "font" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e configure -font {}
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {font "" doesn't exist}
+
+test entry-1.21 {configuration option: "foreground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -foreground #110022
+ .e cget -foreground
+} -cleanup {
+ destroy .e
+} -result {#110022}
+test entry-1.22 {configuration option: "foreground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -foreground non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test entry-1.23 {configuration option: "highlightbackground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -highlightbackground #110022
+ .e cget -highlightbackground
+} -cleanup {
+ destroy .e
+} -result {#110022}
+test entry-1.24 {configuration option: "highlightbackground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -highlightbackground non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test entry-1.25 {configuration option: "highlightcolor" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -highlightcolor #110022
+ .e cget -highlightcolor
+} -cleanup {
+ destroy .e
+} -result {#110022}
+test entry-1.26 {configuration option: "highlightcolor" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -highlightcolor non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test entry-1.27 {configuration option: "highlightthickness" for entry} -setup {
+ entry .e -borderwidth 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -highlightthickness 6
+ .e cget -highlightthickness
+} -cleanup {
+ destroy .e
+} -result {6}
+test entry-1.28 {configuration option: "highlightthickness" for entry} -setup {
+ entry .e -borderwidth 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -highlightthickness -2
+ .e cget -highlightthickness
+} -cleanup {
+ destroy .e
+} -result {0}
+test entry-1.29 {configuration option: "highlightthickness" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -highlightthickness badValue
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+test entry-1.30 {configuration option: "insertbackground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -insertbackground #110022
+ .e cget -insertbackground
+} -cleanup {
+ destroy .e
+} -result {#110022}
+test entry-1.31 {configuration option: "insertbackground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -insertbackground non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test entry-1.32 {configuration option: "insertborderwidth" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -insertborderwidth 1.3
+ .e cget -insertborderwidth
+} -cleanup {
+ destroy .e
+} -result {1}
+test entry-1.33 {configuration option: "insertborderwidth" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -insertborderwidth 2.6x
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad screen distance "2.6x"}
+
+test entry-1.34 {configuration option: "insertofftime" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -insertofftime 100
+ .e cget -insertofftime
+} -cleanup {
+ destroy .e
+} -result {100}
+test entry-1.35 {configuration option: "insertofftime" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -insertofftime 3.2
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected integer but got "3.2"}
+
+test entry-1.36 {configuration option: "insertontime" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -insertontime 100
+ .e cget -insertontime
+} -cleanup {
+ destroy .e
+} -result {100}
+test entry-1.37 {configuration option: "insertontime" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -insertontime 3.2
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected integer but got "3.2"}
+
+test entry-1.38 {configuration option: "invalidcommand" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -invalidcommand "any string"
+ .e cget -invalidcommand
+} -cleanup {
+ destroy .e
+} -result {any string}
+
+test entry-1.39 {configuration option: "invcmd" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -invcmd "any string"
+ .e cget -invcmd
+} -cleanup {
+ destroy .e
+} -result {any string}
+
+test entry-1.40 {configuration option: "justify" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -justify right
+ .e cget -justify
+} -cleanup {
+ destroy .e
+} -result {right}
+test entry-1.41 {configuration option: "justify" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -justify bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad justification "bogus": must be left, right, or center}
+
+test entry-1.42 {configuration option: "readonlybackground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -readonlybackground green
+ .e cget -readonlybackground
+} -cleanup {
+ destroy .e
+} -result {green}
+test entry-1.43 {configuration option: "readonlybackground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -readonlybackground non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test entry-1.44 {configuration option: "relief" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -relief flat
+ .e cget -relief
+} -cleanup {
+ destroy .e
+} -result {flat}
+
+test entry-1.45 {configuration option: "selectbackground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -selectbackground #110022
+ .e cget -selectbackground
+} -cleanup {
+ destroy .e
+} -result {#110022}
+test entry-1.46 {configuration option: "selectbackground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -selectbackground non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test entry-1.47 {configuration option: "selectborderwidth" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -selectborderwidth 1.3
+ .e cget -selectborderwidth
+} -cleanup {
+ destroy .e
+} -result {1}
+test entry-1.48 {configuration option: "selectborderwidth" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -selectborderwidth badValue
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+test entry-1.49 {configuration option: "selectforeground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -selectforeground #110022
+ .e cget -selectforeground
+} -cleanup {
+ destroy .e
+} -result {#110022}
+test entry-1.50 {configuration option: "selectforeground" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -selectforeground non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test entry-1.51 {configuration option: "show" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -show *
+ .e cget -show
+} -cleanup {
+ destroy .e
+} -result {*}
+
+test entry-1.52 {configuration option: "state" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -state n
+ .e cget -state
+} -cleanup {
+ destroy .e
+} -result {normal}
+test entry-1.53 {configuration option: "state" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -state bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad state "bogus": must be disabled, normal, or readonly}
+
+test entry-1.54 {configuration option: "takefocus" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -takefocus "any string"
+ .e cget -takefocus
+} -cleanup {
+ destroy .e
+} -result {any string}
+
+test entry-1.55 {configuration option: "textvariable" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -textvariable i
+ .e cget -textvariable
+} -cleanup {
+ destroy .e
+} -result {i}
+
+test entry-1.56 {configuration option: "width" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -width 402
+ .e cget -width
+} -cleanup {
+ destroy .e
+} -result {402}
+test entry-1.57 {configuration option: "width" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -width 3p
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected integer but got "3p"}
+
+test entry-1.58 {configuration option: "xscrollcommand" for entry} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .e
+ update
+} -body {
+ .e configure -xscrollcommand {Some command}
+ .e cget -xscrollcommand
+} -cleanup {
+ destroy .e
+} -result {Some command}
+
+
+
+test entry-2.1 {Tk_EntryCmd procedure} -body {
+ entry
+} -returnCodes error -result {wrong # args: should be "entry pathName ?-option value ...?"}
+test entry-2.2 {Tk_EntryCmd procedure} -body {
+ entry gorp
+} -returnCodes error -result {bad window path name "gorp"}
+test entry-2.3 {Tk_EntryCmd procedure} -body {
entry .e
+ pack .e
+ update
list [winfo exists .e] [winfo class .e] [info commands .e]
-} {1 Entry .e}
-test entry-2.4 {Tk_EntryCmd procedure} {
- catch {destroy .e}
- list [catch {entry .e -gorp foo} msg] $msg [winfo exists .e] \
- [info commands .e]
-} {1 {unknown option "-gorp"} 0 {}}
-test entry-2.5 {Tk_EntryCmd procedure} {
- catch {destroy .e}
+} -cleanup {
+ destroy .e
+} -result {1 Entry .e}
+test entry-2.4 {Tk_EntryCmd procedure} -body {
+ entry .e -gorp foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {unknown option "-gorp"}
+test entry-2.4.1 {Tk_EntryCmd procedure} -body {
+ catch {entry .e -gorp foo}
+ list [winfo exists .e] [info commands .e]
+} -cleanup {
+ destroy .e
+} -result {0 {}}
+test entry-2.5 {Tk_EntryCmd procedure} -body {
entry .e
-} {.e}
-
-catch {destroy .e}
-entry .e -font $fixed
-pack .e
-update
-
-set cx [font measure $fixed a]
-set cy [font metrics $fixed -linespace]
-set ux [font measure $fixed \u4e4e]
-
-test entry-3.1 {EntryWidgetCmd procedure} {
- list [catch {.e} msg] $msg
-} {1 {wrong # args: should be ".e option ?arg arg ...?"}}
-test entry-3.2 {EntryWidgetCmd procedure, "bbox" widget command} {
- list [catch {.e bbox} msg] $msg
-} {1 {wrong # args: should be ".e bbox index"}}
-test entry-3.3 {EntryWidgetCmd procedure, "bbox" widget command} {
- list [catch {.e bbox a b} msg] $msg
-} {1 {wrong # args: should be ".e bbox index"}}
-test entry-3.4 {EntryWidgetCmd procedure, "bbox" widget command} {
- list [catch {.e bbox bogus} msg] $msg
-} {1 {bad entry index "bogus"}}
-test entry-3.5 {EntryWidgetCmd procedure, "bbox" widget command} {
- .e delete 0 end
- .e bbox 0
-} [list 5 5 0 $cy]
-test entry-3.6 {EntryWidgetCmd procedure, "bbox" widget command} {
- # Tcl_UtfAtIndex(): no utf chars
+} -cleanup {
+ destroy .e
+} -result {.e}
- .e delete 0 end
+
+test entry-3.1 {EntryWidgetCmd procedure} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e option ?arg ...?"}
+test entry-3.2 {EntryWidgetCmd procedure, "bbox" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e bbox
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e bbox index"}
+test entry-3.3 {EntryWidgetCmd procedure, "bbox" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e bbox a b
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e bbox index"}
+test entry-3.4 {EntryWidgetCmd procedure, "bbox" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e bbox bogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "bogus"}
+test entry-3.5 {EntryWidgetCmd procedure, "bbox" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e bbox 0
+} -cleanup {
+ destroy .e
+} -result [list 5 5 0 $cy]
+
+# Previously the result was count using previousli counted font measurements
+# and metrics. It was changed to less verbose solution - the result is the one
+# that passes fonts constraint (this concerns tests 3.6, 3.7, 3.8, 3.10)
+test entry-3.6 {EntryWidgetCmd procedure, "bbox" widget command} -constraints {
+ fonts
+} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+# Tcl_UtfAtIndex(): no utf chars
.e insert 0 "abc"
list [.e bbox 3] [.e bbox end]
-} [list "[expr 5+2*$cx] 5 $cx $cy" "[expr 5+2*$cx] 5 $cx $cy"]
-test entry-3.7 {EntryWidgetCmd procedure, "bbox" widget command} {
- # Tcl_UtfAtIndex(): utf at end
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {{19 5 7 13} {19 5 7 13}}
+test entry-3.7 {EntryWidgetCmd procedure, "bbox" widget command} -constraints {
+ fonts
+} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+# Tcl_UtfAtIndex(): utf at end
.e insert 0 "ab\u4e4e"
.e bbox end
-} "[expr 5+2*$cx] 5 $ux $cy"
-test entry-3.8 {EntryWidgetCmd procedure, "bbox" widget command} {
- # Tcl_UtfAtIndex(): utf before index
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {19 5 12 13}
+test entry-3.8 {EntryWidgetCmd procedure, "bbox" widget command} -constraints {
+ fonts
+} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+# Tcl_UtfAtIndex(): utf before index
.e insert 0 "ab\u4e4ec"
.e bbox 3
-} "[expr 5+2*$cx+$ux] 5 $cx $cy"
-test entry-3.9 {EntryWidgetCmd procedure, "bbox" widget command} {
- # Tcl_UtfAtIndex(): no chars
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {31 5 7 13}
+test entry-3.9 {EntryWidgetCmd procedure, "bbox" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+# Tcl_UtfAtIndex(): no chars
.e bbox end
-} "5 5 0 $cy"
-test entry-3.10 {EntryWidgetCmd procedure, "bbox" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result "5 5 0 $cy"
+test entry-3.10 {EntryWidgetCmd procedure, "bbox" widget command} -constraints {
+ fonts
+} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
.e insert 0 "abcdefghij\u4e4eklmnop"
list [.e bbox 0] [.e bbox 1] [.e bbox 10] [.e bbox end]
-} [list "5 5 $cx $cy" "[expr 5+$cx] 5 $cx $cy" "[expr 5+10*$cx] 5 $ux $cy" "[expr 5+$ux+15*$cx] 5 $cx $cy"]
-test entry-3.11 {EntryWidgetCmd procedure, "cget" widget command} {
- list [catch {.e cget} msg] $msg
-} {1 {wrong # args: should be ".e cget option"}}
-test entry-3.12 {EntryWidgetCmd procedure, "cget" widget command} {
- list [catch {.e cget a b} msg] $msg
-} {1 {wrong # args: should be ".e cget option"}}
-test entry-3.13 {EntryWidgetCmd procedure, "cget" widget command} {
- list [catch {.e cget -gorp} msg] $msg
-} {1 {unknown option "-gorp"}}
-test entry-3.14 {EntryWidgetCmd procedure, "cget" widget command} {
+} -cleanup {
+ destroy .e
+} -result {{5 5 7 13} {12 5 7 13} {75 5 12 13} {122 5 7 13}}
+test entry-3.11 {EntryWidgetCmd procedure, "cget" widget command} -setup {
+ entry .e
+} -body {
+ .e cget
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e cget option"}
+test entry-3.12 {EntryWidgetCmd procedure, "cget" widget command} -setup {
+ entry .e
+} -body {
+ .e cget a b
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e cget option"}
+test entry-3.13 {EntryWidgetCmd procedure, "cget" widget command} -setup {
+ entry .e
+} -body {
+ .e cget -gorp
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {unknown option "-gorp"}
+test entry-3.14 {EntryWidgetCmd procedure, "cget" widget command} -setup {
+ entry .e
+} -body {
.e configure -bd 4
.e cget -bd
-} {4}
-test entry-3.15 {EntryWidgetCmd procedure, "configure" widget command} {
+} -cleanup {
+ destroy .e
+} -result {4}
+test entry-3.15 {EntryWidgetCmd procedure, "configure" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
llength [.e configure]
-} {36}
-test entry-3.16 {EntryWidgetCmd procedure, "configure" widget command} {
- list [catch {.e configure -foo} msg] $msg
-} {1 {unknown option "-foo"}}
-test entry-3.17 {EntryWidgetCmd procedure, "configure" widget command} {
+} -cleanup {
+ destroy .e
+} -result {36}
+test entry-3.16 {EntryWidgetCmd procedure, "configure" widget command} -setup {
+ entry .e
+} -body {
+ .e configure -foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {unknown option "-foo"}
+test entry-3.17 {EntryWidgetCmd procedure, "configure" widget command} -setup {
+ entry .e
+} -body {
.e configure -bd 4
.e configure -bg #ffffff
lindex [.e configure -bd] 4
-} {4}
-test entry-3.18 {EntryWidgetCmd procedure, "delete" widget command} {
- list [catch {.e delete} msg] $msg
-} {1 {wrong # args: should be ".e delete firstIndex ?lastIndex?"}}
-test entry-3.19 {EntryWidgetCmd procedure, "delete" widget command} {
- list [catch {.e delete a b c} msg] $msg
-} {1 {wrong # args: should be ".e delete firstIndex ?lastIndex?"}}
-test entry-3.20 {EntryWidgetCmd procedure, "delete" widget command} {
- list [catch {.e delete foo} msg] $msg
-} {1 {bad entry index "foo"}}
-test entry-3.21 {EntryWidgetCmd procedure, "delete" widget command} {
- list [catch {.e delete 0 bar} msg] $msg
-} {1 {bad entry index "bar"}}
-test entry-3.22 {EntryWidgetCmd procedure, "delete" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {4}
+test entry-3.18 {EntryWidgetCmd procedure, "delete" widget command} -setup {
+ entry .e
+} -body {
+ .e delete
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e delete firstIndex ?lastIndex?"}
+test entry-3.19 {EntryWidgetCmd procedure, "delete" widget command} -setup {
+ entry .e
+} -body {
+ .e delete a b c
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e delete firstIndex ?lastIndex?"}
+test entry-3.20 {EntryWidgetCmd procedure, "delete" widget command} -setup {
+ entry .e
+} -body {
+ .e delete foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "foo"}
+test entry-3.21 {EntryWidgetCmd procedure, "delete" widget command} -setup {
+ entry .e
+} -body {
+ .e delete 0 bar
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "bar"}
+test entry-3.22 {EntryWidgetCmd procedure, "delete" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
.e insert end "01234567890"
.e delete 2 4
.e get
-} {014567890}
-test entry-3.23 {EntryWidgetCmd procedure, "delete" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {014567890}
+test entry-3.23 {EntryWidgetCmd procedure, "delete" widget command} -setup {
+ entry .e
+} -body {
.e insert end "01234567890"
.e delete 6
.e get
-} {0123457890}
-test entry-3.24 {EntryWidgetCmd procedure, "delete" widget command} {
- # UTF
+} -cleanup {
+ destroy .e
+} -result {0123457890}
+test entry-3.24 {EntryWidgetCmd procedure, "delete" widget command} -setup {
+ entry .e
+ pack .e
+ update
set x {}
- .e delete 0 end
+} -body {
+# UTF
.e insert end "01234\u4e4e67890"
.e delete 6
lappend x [.e get]
@@ -232,311 +891,659 @@ test entry-3.24 {EntryWidgetCmd procedure, "delete" widget command} {
.e insert end "0123456\u4e4e890"
.e delete 6
lappend x [.e get]
-} [list "01234\u4e4e7890" "0123457890" "012345\u4e4e890"]
-test entry-3.25 {EntryWidgetCmd procedure, "delete" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result [list "01234\u4e4e7890" "0123457890" "012345\u4e4e890"]
+test entry-3.25 {EntryWidgetCmd procedure, "delete" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
.e insert end "01234567890"
.e delete 6 5
.e get
-} {01234567890}
-test entry-3.26 {EntryWidgetCmd procedure, "delete" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {01234567890}
+test entry-3.26 {EntryWidgetCmd procedure, "delete" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
.e insert end "01234567890"
.e configure -state disabled
.e delete 2 8
.e configure -state normal
.e get
-} {01234567890}
-test entry-3.26a {EntryWidgetCmd procedure, "delete" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {01234567890}
+test entry-3.26a {EntryWidgetCmd procedure, "delete" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
.e insert end "01234567890"
.e configure -state readonly
.e delete 2 8
.e configure -state normal
.e get
-} {01234567890}
-test entry-3.27 {EntryWidgetCmd procedure, "get" widget command} {
- list [catch {.e get foo} msg] $msg
-} {1 {wrong # args: should be ".e get"}}
-test entry-3.28 {EntryWidgetCmd procedure, "icursor" widget command} {
- list [catch {.e icursor} msg] $msg
-} {1 {wrong # args: should be ".e icursor pos"}}
-test entry-3.29 {EntryWidgetCmd procedure, "icursor" widget command} {
- list [catch {.e icursor foo} msg] $msg
-} {1 {bad entry index "foo"}}
-test entry-3.30 {EntryWidgetCmd procedure, "icursor" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {01234567890}
+test entry-3.27 {EntryWidgetCmd procedure, "get" widget command} -setup {
+ entry .e
+} -body {
+ .e get foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e get"}
+test entry-3.28 {EntryWidgetCmd procedure, "icursor" widget command} -setup {
+ entry .e
+} -body {
+ .e icursor
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e icursor pos"}
+test entry-3.29 {EntryWidgetCmd procedure, "icursor" widget command} -setup {
+ entry .e
+} -body {
+ .e icursor foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "foo"}
+test entry-3.30 {EntryWidgetCmd procedure, "icursor" widget command} -setup {
+ entry .e
+} -body {
.e insert end "01234567890"
.e icursor 4
.e index insert
-} {4}
-test entry-3.31 {EntryWidgetCmd procedure, "index" widget command} {
- list [catch {.e in} msg] $msg
-} {1 {ambiguous option "in": must be bbox, cget, configure, delete, get, icursor, index, insert, scan, selection, validate, or xview}}
-test entry-3.32 {EntryWidgetCmd procedure, "index" widget command} {
- list [catch {.e index} msg] $msg
-} {1 {wrong # args: should be ".e index string"}}
-test entry-3.33 {EntryWidgetCmd procedure, "index" widget command} {
- list [catch {.e index foo} msg] $msg
-} {1 {bad entry index "foo"}}
-test entry-3.34 {EntryWidgetCmd procedure, "index" widget command} {
- list [catch {.e index 0} msg] $msg
-} {0 0}
-test entry-3.35 {EntryWidgetCmd procedure, "index" widget command} {
- # UTF
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {4}
+test entry-3.31 {EntryWidgetCmd procedure, "index" widget command} -setup {
+ entry .e
+} -body {
+ .e in
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {ambiguous option "in": must be bbox, cget, configure, delete, get, icursor, index, insert, scan, selection, validate, or xview}
+test entry-3.32 {EntryWidgetCmd procedure, "index" widget command} -setup {
+ entry .e
+} -body {
+ .e index
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e index string"}
+test entry-3.33 {EntryWidgetCmd procedure, "index" widget command} -setup {
+ entry .e
+} -body {
+ .e index foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "foo"}
+test entry-3.34 {EntryWidgetCmd procedure, "index" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e index 0
+} -cleanup {
+ destroy .e
+} -returnCodes {ok} -match glob -result {*}
+test entry-3.35 {EntryWidgetCmd procedure, "index" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+# UTF
.e insert 0 abc\u4e4e\u0153def
list [.e index 3] [.e index 4] [.e index end]
-} {3 4 8}
-test entry-3.36 {EntryWidgetCmd procedure, "insert" widget command} {
- list [catch {.e insert a} msg] $msg
-} {1 {wrong # args: should be ".e insert index text"}}
-test entry-3.37 {EntryWidgetCmd procedure, "insert" widget command} {
- list [catch {.e insert a b c} msg] $msg
-} {1 {wrong # args: should be ".e insert index text"}}
-test entry-3.38 {EntryWidgetCmd procedure, "insert" widget command} {
- list [catch {.e insert foo Text} msg] $msg
-} {1 {bad entry index "foo"}}
-test entry-3.39 {EntryWidgetCmd procedure, "insert" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {3 4 8}
+test entry-3.36 {EntryWidgetCmd procedure, "insert" widget command} -setup {
+ entry .e
+} -body {
+ .e insert a
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e insert index text"}
+test entry-3.37 {EntryWidgetCmd procedure, "insert" widget command} -setup {
+ entry .e
+} -body {
+ .e insert a b c
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e insert index text"}
+test entry-3.38 {EntryWidgetCmd procedure, "insert" widget command} -setup {
+ entry .e
+} -body {
+ .e insert foo Text
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "foo"}
+test entry-3.39 {EntryWidgetCmd procedure, "insert" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
.e insert end "01234567890"
.e insert 3 xxx
.e get
-} {012xxx34567890}
-test entry-3.40 {EntryWidgetCmd procedure, "insert" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {012xxx34567890}
+test entry-3.40 {EntryWidgetCmd procedure, "insert" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
.e insert end "01234567890"
.e configure -state disabled
.e insert 3 xxx
.e configure -state normal
.e get
-} {01234567890}
-test entry-3.40a {EntryWidgetCmd procedure, "insert" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {01234567890}
+test entry-3.40a {EntryWidgetCmd procedure, "insert" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
.e insert end "01234567890"
.e configure -state readonly
.e insert 3 xxx
.e configure -state normal
.e get
-} {01234567890}
-test entry-3.41 {EntryWidgetCmd procedure, "insert" widget command} {
- list [catch {.e insert a b c} msg] $msg
-} {1 {wrong # args: should be ".e insert index text"}}
-test entry-3.42 {EntryWidgetCmd procedure, "scan" widget command} {
- list [catch {.e scan a} msg] $msg
-} {1 {wrong # args: should be ".e scan mark|dragto x"}}
-test entry-3.43 {EntryWidgetCmd procedure, "scan" widget command} {
- list [catch {.e scan a b c} msg] $msg
-} {1 {wrong # args: should be ".e scan mark|dragto x"}}
-test entry-3.44 {EntryWidgetCmd procedure, "scan" widget command} {
- list [catch {.e scan foobar 20} msg] $msg
-} {1 {bad scan option "foobar": must be mark or dragto}}
-test entry-3.45 {EntryWidgetCmd procedure, "scan" widget command} {
- list [catch {.e scan mark 20.1} msg] $msg
-} {1 {expected integer but got "20.1"}}
-# This test is non-portable because character sizes vary.
+} -cleanup {
+ destroy .e
+} -result {01234567890}
+test entry-3.41 {EntryWidgetCmd procedure, "insert" widget command} -setup {
+ entry .e
+} -body {
+ .e insert a b c
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e insert index text"}
+test entry-3.42 {EntryWidgetCmd procedure, "scan" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e scan a
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e scan mark|dragto x"}
+test entry-3.43 {EntryWidgetCmd procedure, "scan" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e scan a b c
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e scan mark|dragto x"}
+test entry-3.44 {EntryWidgetCmd procedure, "scan" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e scan foobar 20
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad scan option "foobar": must be mark or dragto}
+test entry-3.45 {EntryWidgetCmd procedure, "scan" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e scan mark 20.1
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {expected integer but got "20.1"}
-test entry-3.46 {EntryWidgetCmd procedure, "scan" widget command} {fonts} {
- .e delete 0 end
+# This test is non-portable because character sizes vary.
+test entry-3.46 {EntryWidgetCmd procedure, "scan" widget command} -constraints {
+ fonts
+} -setup {
+ entry .e -font {Helvetica -12} -borderwidth 2 -highlightthickness 2
+ pack .e
update
+} -body {
.e insert end "This is quite a long string, in fact a "
.e insert end "very very long string"
.e scan mark 30
.e scan dragto 28
.e index @0
-} {2}
-test entry-3.47 {EntryWidgetCmd procedure, "select" widget command} {
- list [catch {.e select} msg] $msg
-} {1 {wrong # args: should be ".e selection option ?index?"}}
-test entry-3.48 {EntryWidgetCmd procedure, "select" widget command} {
- list [catch {.e select foo} msg] $msg
-} {1 {bad selection option "foo": must be adjust, clear, from, present, range, or to}}
-test entry-3.49 {EntryWidgetCmd procedure, "select clear" widget command} {
- list [catch {.e select clear gorp} msg] $msg
-} {1 {wrong # args: should be ".e selection clear"}}
-test entry-3.50 {EntryWidgetCmd procedure, "select clear" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {2}
+test entry-3.47 {EntryWidgetCmd procedure, "select" widget command} -setup {
+ entry .e
+} -body {
+ .e select
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection option ?index?"}
+test entry-3.48 {EntryWidgetCmd procedure, "select" widget command} -setup {
+ entry .e
+} -body {
+ .e select foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad selection option "foo": must be adjust, clear, from, present, range, or to}
+
+test entry-3.49 {EntryWidgetCmd procedure, "select clear" widget command} -setup {
+ entry .e
+} -body {
+ .e select clear gorp
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection clear"}
+test entry-3.50 {EntryWidgetCmd procedure, "select clear" widget command} -setup {
+ entry .e
+} -body {
.e insert end "0123456789"
.e select from 1
.e select to 4
update
.e select clear
- list [catch {selection get} msg] $msg [selection own]
-} {1 {PRIMARY selection doesn't exist or form "STRING" not defined} .e}
-test entry-3.51 {EntryWidgetCmd procedure, "selection present" widget command} {
- list [catch {.e selection present foo} msg] $msg
-} {1 {wrong # args: should be ".e selection present"}}
-test entry-3.52 {EntryWidgetCmd procedure, "selection present" widget command} {
- .e delete 0 end
+ selection get
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {PRIMARY selection doesn't exist or form "STRING" not defined}
+test entry-3.50.1 {EntryWidgetCmd procedure, "select clear" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e insert end "0123456789"
+ .e select from 1
+ .e select to 4
+ update
+ .e select clear
+ catch {selection get}
+ selection own
+} -cleanup {
+ destroy .e
+} -result {.e}
+
+test entry-3.51 {EntryWidgetCmd procedure, "selection present" widget command} -setup {
+ entry .e
+} -body {
+ .e selection present foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection present"}
+test entry-3.52 {EntryWidgetCmd procedure, "selection present" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
.e insert end 0123456789
.e select from 3
.e select to 6
.e selection present
-} {1}
-test entry-3.53 {EntryWidgetCmd procedure, "selection present" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {1}
+test entry-3.53 {EntryWidgetCmd procedure, "selection present" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
.e insert end 0123456789
.e select from 3
.e select to 6
.e configure -exportselection false
.e selection present
-} {1}
-.e configure -exportselection true
-test entry-3.54 {EntryWidgetCmd procedure, "selection present" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {1}
+test entry-3.54 {EntryWidgetCmd procedure, "selection present" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
.e insert end 0123456789
.e select from 3
.e select to 6
.e delete 0 end
.e selection present
-} {0}
-test entry-3.55 {EntryWidgetCmd procedure, "selection adjust" widget command} {
- list [catch {.e select adjust x} msg] $msg
-} {1 {bad entry index "x"}}
-test entry-3.56 {EntryWidgetCmd procedure, "selection adjust" widget command} {
- list [catch {.e select adjust 2 3} msg] $msg
-} {1 {wrong # args: should be ".e selection adjust index"}}
-test entry-3.57 {EntryWidgetCmd procedure, "selection adjust" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {0}
+test entry-3.55 {EntryWidgetCmd procedure, "selection adjust" widget command} -setup {
+ entry .e
+} -body {
+ .e select adjust x
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "x"}
+test entry-3.56 {EntryWidgetCmd procedure, "selection adjust" widget command} -setup {
+ entry .e
+} -body {
+ .e select adjust 2 3
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection adjust index"}
+test entry-3.57 {EntryWidgetCmd procedure, "selection adjust" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
.e insert end "0123456789"
.e select from 1
.e select to 5
update
.e select adjust 4
selection get
-} {123}
-test entry-3.58 {EntryWidgetCmd procedure, "selection adjust" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {123}
+test entry-3.58 {EntryWidgetCmd procedure, "selection adjust" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
.e insert end "0123456789"
.e select from 1
.e select to 5
update
.e select adjust 2
selection get
-} {234}
-test entry-3.59 {EntryWidgetCmd procedure, "selection from" widget command} {
- list [catch {.e select from 2 3} msg] $msg
-} {1 {wrong # args: should be ".e selection from index"}}
-test entry-3.60 {EntryWidgetCmd procedure, "selection range" widget command} {
- list [catch {.e select range 2} msg] $msg
-} {1 {wrong # args: should be ".e selection range start end"}}
-test entry-3.61 {EntryWidgetCmd procedure, "selection range" widget command} {
- list [catch {.e selection range 2 3 4} msg] $msg
-} {1 {wrong # args: should be ".e selection range start end"}}
-test entry-3.62 {EntryWidgetCmd procedure, "selection range" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {234}
+test entry-3.59 {EntryWidgetCmd procedure, "selection from" widget command} -setup {
+ entry .e
+} -body {
+ .e select from 2 3
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection from index"}
+
+test entry-3.60 {EntryWidgetCmd procedure, "selection range" widget command} -setup {
+ entry .e
+} -body {
+ .e select range 2
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection range start end"}
+test entry-3.61 {EntryWidgetCmd procedure, "selection range" widget command} -setup {
+ entry .e
+} -body {
+ .e selection range 2 3 4
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection range start end"}
+test entry-3.62 {EntryWidgetCmd procedure, "selection range" widget command} -setup {
+ entry .e
+} -body {
.e insert end 0123456789
.e select from 1
.e select to 5
.e select range 4 4
- list [catch {.e index sel.first} msg] $msg
-} {1 {selection isn't in widget .e}}
-test entry-3.63 {EntryWidgetCmd procedure, "selection range" widget command} {
- .e delete 0 end
+ .e index sel.first
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {selection isn't in widget .e}
+test entry-3.63 {EntryWidgetCmd procedure, "selection range" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
.e insert end 0123456789
.e select from 3
.e select to 7
.e select range 2 9
list [.e index sel.first] [.e index sel.last] [.e index anchor]
-} {2 9 3}
-test entry-3.64 {EntryWidgetCmd procedure, "selection" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {2 9 3}
+test entry-3.64 {EntryWidgetCmd procedure, "selection" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
.e insert end 0123456789
.e selection range 0 end
.e configure -state disabled
.e selection range 2 4
.e configure -state normal
list [.e index sel.first] [.e index sel.last]
-} {0 10}
-test entry-3.64a {EntryWidgetCmd procedure, "selection" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {0 10}
+test entry-3.64a {EntryWidgetCmd procedure, "selection" widget command} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
.e insert end 0123456789
.e selection range 0 end
.e configure -state readonly
.e selection range 2 4
.e configure -state normal
list [.e index sel.first] [.e index sel.last]
-} {2 4}
-.e delete 0 end
-.e insert end "This is quite a long text string, so long that it "
-.e insert end "runs off the end of the window quite a bit."
-test entry-3.64b {EntryWidgetCmd procedure, "selection to" widget command} {
- list [catch {.e select to 2 3} msg] $msg
-} {1 {wrong # args: should be ".e selection to index"}}
-test entry-3.65 {EntryWidgetCmd procedure, "xview" widget command} {
+} -cleanup {
+ destroy .e
+} -result {2 4}
+test entry-3.64b {EntryWidgetCmd procedure, "selection to" widget command} -setup {
+ entry .e
+ pack .e
+ update
+ .e insert end "This is quite a long text string, so long that it "
+ .e insert end "runs off the end of the window quite a bit."
+} -body {
+ .e select to 2 3
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection to index"}
+
+test entry-3.65 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e insert end "This is quite a long text string, so long that it "
+ .e insert end "runs off the end of the window quite a bit."
.e xview 5
format {%.7f %.7f} {*}[.e xview]
-} {0.0537634 0.2688172}
-test entry-3.66 {EntryWidgetCmd procedure, "xview" widget command} {
- list [catch {.e xview gorp} msg] $msg
-} {1 {bad entry index "gorp"}}
-test entry-3.67 {EntryWidgetCmd procedure, "xview" widget command} {
+} -cleanup {
+ destroy .e
+} -result {0.0537634 0.2688172}
+test entry-3.66 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e xview gorp
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "gorp"}
+test entry-3.67 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e insert end "This is quite a long text string, so long that it "
+ .e insert end "runs off the end of the window quite a bit."
.e xview 0
.e icursor 10
.e xview insert
format {%.6f %.6f} {*}[.e xview]
-} {0.107527 0.322581}
-test entry-3.68 {EntryWidgetCmd procedure, "xview" widget command} {
- list [catch {.e xview moveto foo bar} msg] $msg
-} {1 {wrong # args: should be ".e xview moveto fraction"}}
-test entry-3.69 {EntryWidgetCmd procedure, "xview" widget command} {
- list [catch {.e xview moveto foo} msg] $msg
-} {1 {expected floating-point number but got "foo"}}
-test entry-3.70 {EntryWidgetCmd procedure, "xview" widget command} {
+} -cleanup {
+ destroy .e
+} -result {0.107527 0.322581}
+test entry-3.68 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e xview moveto foo bar
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e xview moveto fraction"}
+test entry-3.69 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e xview moveto foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {expected floating-point number but got "foo"}
+test entry-3.70 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e insert end "This is quite a long text string, so long that it "
+ .e insert end "runs off the end of the window quite a bit."
.e xview moveto 0.5
format {%.6f %.6f} {*}[.e xview]
-} {0.505376 0.720430}
-test entry-3.71 {EntryWidgetCmd procedure, "xview" widget command} {
- list [catch {.e xview scroll 24} msg] $msg
-} {1 {wrong # args: should be ".e xview scroll number units|pages"}}
-test entry-3.72 {EntryWidgetCmd procedure, "xview" widget command} {
- list [catch {.e xview scroll gorp units} msg] $msg
-} {1 {expected integer but got "gorp"}}
-test entry-3.73 {EntryWidgetCmd procedure, "xview" widget command} {
+} -cleanup {
+ destroy .e
+} -result {0.505376 0.720430}
+test entry-3.71 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e insert end "This is quite a long text string, so long that it "
+ .e insert end "runs off the end of the window quite a bit."
+ .e xview scroll 24
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e xview scroll number units|pages"}
+test entry-3.72 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .e insert end "This is quite a long text string, so long that it "
+ .e insert end "runs off the end of the window quite a bit."
+ update
+ .e xview scroll gorp units
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {expected integer but got "gorp"}
+test entry-3.73 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .e insert end "This is quite a long text string, so long that it "
+ .e insert end "runs off the end of the window quite a bit."
+ update
.e xview moveto 0
.e xview scroll 1 pages
format {%.6f %.6f} {*}[.e xview]
-} {0.193548 0.408602}
-test entry-3.74 {EntryWidgetCmd procedure, "xview" widget command} {
+} -cleanup {
+ destroy .e
+} -result {0.193548 0.408602}
+test entry-3.74 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e insert end "This is quite a long text string, so long that it "
+ .e insert end "runs off the end of the window quite a bit."
.e xview moveto .9
update
.e xview scroll -2 p
format {%.6f %.6f} {*}[.e xview]
-} {0.397849 0.612903}
-test entry-3.75 {EntryWidgetCmd procedure, "xview" widget command} {
+} -cleanup {
+ destroy .e
+} -result {0.397849 0.612903}
+test entry-3.75 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .e insert end "This is quite a long text string, so long that it "
+ .e insert end "runs off the end of the window quite a bit."
+ update
.e xview 30
update
.e xview scroll 2 units
.e index @0
-} {32}
-test entry-3.76 {EntryWidgetCmd procedure, "xview" widget command} {
+} -cleanup {
+ destroy .e
+} -result {32}
+test entry-3.76 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .e insert end "This is quite a long text string, so long that it "
+ .e insert end "runs off the end of the window quite a bit."
+ update
.e xview 30
update
.e xview scroll -1 units
.e index @0
-} {29}
-test entry-3.77 {EntryWidgetCmd procedure, "xview" widget command} {
- list [catch {.e xview scroll 23 foobars} msg] $msg
-} {1 {bad argument "foobars": must be units or pages}}
-test entry-3.78 {EntryWidgetCmd procedure, "xview" widget command} {
- list [catch {.e xview eat 23 hamburgers} msg] $msg
-} {1 {unknown option "eat": must be moveto or scroll}}
-test entry-3.79 {EntryWidgetCmd procedure, "xview" widget command} {
+} -cleanup {
+ destroy .e
+} -result {29}
+test entry-3.77 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .e insert end "This is quite a long text string, so long that it "
+ .e insert end "runs off the end of the window quite a bit."
+ update
+ .e xview scroll 23 foobars
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad argument "foobars": must be units or pages}
+test entry-3.78 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .e insert end "This is quite a long text string, so long that it "
+ .e insert end "runs off the end of the window quite a bit."
+ update
+ .e xview eat 23 hamburgers
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {unknown option "eat": must be moveto or scroll}
+test entry-3.79 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e insert end "This is quite a long text string, so long that it "
+ .e insert end "runs off the end of the window quite a bit."
.e xview 0
update
.e xview -4
.e index @0
-} {0}
-test entry-3.80 {EntryWidgetCmd procedure, "xview" widget command} {
+} -cleanup {
+ destroy .e
+} -result {0}
+test entry-3.80 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .e insert end "This is quite a long text string, so long that it "
+ .e insert end "runs off the end of the window quite a bit."
+ update
.e xview 300
.e index @0
-} {73}
-.e insert 10 \u4e4e
-test entry-3.81 {EntryWidgetCmd procedure, "xview" widget command} {
- # UTF
- # If Tcl_NumUtfChars wasn't used, wrong answer would be:
- # 0.106383 0.117021 0.117021
-
+} -cleanup {
+ destroy .e
+} -result {73}
+test entry-3.86 {EntryWidgetCmd procedure, "xview" widget command} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+ .e insert end "This is quite a long text string, so long that it "
+ .e insert end "runs off the end of the window quite a bit."
+ .e insert 10 \u4e4e
+ update
+# UTF
+# If Tcl_NumUtfChars wasn't used, wrong answer would be:
+# 0.106383 0.117021 0.117021
set x {}
.e xview moveto .1
lappend x [format {%.6f} [lindex [.e xview] 0]]
@@ -544,261 +1551,382 @@ test entry-3.81 {EntryWidgetCmd procedure, "xview" widget command} {
lappend x [format {%.6f} [lindex [.e xview] 0]]
.e xview moveto .12
lappend x [format {%.6f} [lindex [.e xview] 0]]
-} {0.095745 0.106383 0.117021}
-test entry-3.82 {EntryWidgetCmd procedure} {
- list [catch {.e gorp} msg] $msg
-} {1 {bad option "gorp": must be bbox, cget, configure, delete, get, icursor, index, insert, scan, selection, validate, or xview}}
+} -cleanup {
+ destroy .e
+} -result {0.095745 0.106383 0.117021}
+
+test entry-3.82 {EntryWidgetCmd procedure} -setup {
+ entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e gorp
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad option "gorp": must be bbox, cget, configure, delete, get, icursor, index, insert, scan, selection, validate, or xview}
# The test below doesn't actually check anything directly, but if run
# with Purify or some other memory-allocation-checking program it will
# ensure that resources get properly freed.
-test entry-4.1 {DestroyEntry procedure} {
- catch {destroy .e}
+test entry-4.1 {DestroyEntry procedure} -body {
entry .e -textvariable x -show *
pack .e
.e insert end "Sample text"
update
destroy .e
-} {}
+} -result {}
-frame .f -width 200 -height 50 -relief raised -bd 2
-pack .f -side right
-test entry-5.1 {ConfigureEntry procedure, -textvariable} {
- catch {destroy .e}
+test entry-5.1 {ConfigureEntry procedure, -textvariable} -body {
set x 12345
entry .e -textvariable x
.e get
-} {12345}
-test entry-5.2 {ConfigureEntry procedure, -textvariable} {
- catch {destroy .e}
+} -cleanup {
+ destroy .e
+} -result {12345}
+test entry-5.2 {ConfigureEntry procedure, -textvariable} -body {
set x 12345
entry .e -textvariable x
set y abcde
.e configure -textvariable y
set x 54321
.e get
-} {abcde}
-test entry-5.3 {ConfigureEntry procedure, -textvariable} {
- catch {destroy .e}
- catch {unset x}
+} -cleanup {
+ destroy .e
+} -result {abcde}
+test entry-5.3 {ConfigureEntry procedure, -textvariable} -setup {
+ unset -nocomplain x
entry .e
+} -body {
.e insert 0 "Some text"
.e configure -textvariable x
- set x
-} {Some text}
-test entry-5.4 {ConfigureEntry procedure, -textvariable} {
- proc override args {
- global x
- set x 12345
- }
- catch {destroy .e}
- catch {unset x}
- trace variable x w override
+ return $x
+} -cleanup {
+ destroy .e
+} -result {Some text}
+test entry-5.4 {ConfigureEntry procedure, -textvariable} -setup {
+ unset -nocomplain x
entry .e
+} -body {
+ trace variable x w override
.e insert 0 "Some text"
.e configure -textvariable x
- set result [list $x [.e get]]
- unset x; rename override {}
- set result
-} {12345 12345}
-test entry-5.5 {ConfigureEntry procedure} {
- catch {destroy .e}
- entry .e -exportselection false
- pack .e
- .e insert end "0123456789"
- .sel select from 0
- .sel select to 10
+ list $x [.e get]
+} -cleanup {
+ destroy .e
+ trace vdelete x w override
+ unset x;
+} -result {12345 12345}
+
+test entry-5.5 {ConfigureEntry procedure} -setup {
set x {}
+ entry .e1
+ entry .e2
+} -body {
+ .e2 insert end "This is some sample text"
+ .e1 configure -exportselection false
+ .e1 insert end "0123456789"
+ pack .e1 .e2
+ .e2 select from 0
+ .e2 select to 10
lappend x [selection get]
- .e select from 1
- .e select to 5
+ .e1 select from 1
+ .e1 select to 5
lappend x [selection get]
- .e configure -exportselection 1
+ .e1 configure -exportselection 1
lappend x [selection get]
- set x
-} {{This is so} {This is so} 1234}
-test entry-5.6 {ConfigureEntry procedure} {
- catch {destroy .e}
+ return $x
+} -cleanup {
+ destroy .e1 .e2
+} -result {{This is so} {This is so} 1234}
+test entry-5.6 {ConfigureEntry procedure} -setup {
+ entry .e
+ pack .e
+} -body {
+ .e insert end "0123456789"
+ .e select from 1
+ .e select to 5
+ .e configure -exportselection 0
+ selection get
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {PRIMARY selection doesn't exist or form "STRING" not defined}
+test entry-5.6.1 {ConfigureEntry procedure} -setup {
entry .e
pack .e
+} -body {
.e insert end "0123456789"
.e select from 1
.e select to 5
.e configure -exportselection 0
- list [catch {selection get} msg] $msg [.e index sel.first] \
- [.e index sel.last]
-} {1 {PRIMARY selection doesn't exist or form "STRING" not defined} 1 5}
-test entry-5.7 {ConfigureEntry procedure} {
- catch {destroy .e}
- entry .e -font $fixed -width 4 -xscrollcommand scroll
+ catch {selection get}
+ list [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {1 5}
+
+test entry-5.7 {ConfigureEntry procedure} -setup {
+ entry .e -font {Helvetica -12} -borderwidth 2 -highlightthickness 2
pack .e
+} -body {
+ .e configure -font {Courier -12} -width 4 -xscrollcommand scroll
.e insert end "01234567890"
update
.e configure -width 5
format {%.6f %.6f} {*}$scrollInfo
-} {0.000000 0.363636}
-test entry-5.8 {ConfigureEntry procedure} {fonts} {
- catch {destroy .e}
- entry .e -width 0
+} -cleanup {
+ destroy .e
+} -result {0.000000 0.363636}
+
+
+test entry-5.8 {ConfigureEntry procedure} -constraints {
+ fonts
+} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2
pack .e
+} -body {
+ .e configure -width 0 -font {Helvetica -12}
.e insert end "0123"
update
- .e configure -font $big
+ .e configure -font {Helvetica -24}
update
winfo geom .e
-} {62x37+0+0}
-test entry-5.9 {ConfigureEntry procedure} {fonts} {
- catch {destroy .e}
- entry .e -font $fixed -bd 2 -relief raised
+} -cleanup {
+ destroy .e
+} -result {62x37+0+0}
+test entry-5.9 {ConfigureEntry procedure} -constraints {
+ fonts
+} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2
pack .e
+} -body {
+ .e configure -font {Courier -12} -bd 2 -relief raised
.e insert end "0123"
update
list [.e index @10] [.e index @11] [.e index @12] [.e index @13]
-} {0 0 1 1}
-test entry-5.10 {ConfigureEntry procedure} {fonts} {
- catch {destroy .e}
- entry .e -font $fixed -bd 2 -relief flat
+} -cleanup {
+ destroy .e
+} -result {0 0 1 1}
+test entry-5.10 {ConfigureEntry procedure} -constraints {
+ fonts
+} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2
pack .e
+} -body {
+ .e configure -font {Courier -12} -bd 2 -relief flat
.e insert end "0123"
update
list [.e index @10] [.e index @11] [.e index @12] [.e index @13]
-} {0 0 1 1}
-test entry-5.11 {ConfigureEntry procedure} {
- # If "0" in selected font had 0 width, caused divide-by-zero error.
-
- catch {destroy .e}
- pack [entry .e -font {{open look glyph}}]
+} -cleanup {
+ destroy .e
+} -result {0 0 1 1}
+test entry-5.11 {ConfigureEntry procedure} -setup {
+ entry .e -borderwidth 2 -highlightthickness 2
+ pack .e
+} -body {
+# If "0" in selected font had 0 width, caused divide-by-zero error.
+ .e configure -font {{open look glyph}}
.e scan dragto 30
update
-} {}
+} -cleanup {
+ destroy .e
+} -result {}
# No tests for DisplayEntry.
-test entry-6.1 {EntryComputeGeometry procedure} {fonts} {
- catch {destroy .e}
- entry .e -font $fixed -bd 2 -relief raised -width 20 -highlightthickness 3
+test entry-6.1 {EntryComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ entry .e
pack .e
+} -body {
+ .e configure -font {Courier -12} -bd 2 -relief raised -width 20 \
+ -highlightthickness 3
.e insert end 012\t45
update
list [.e index @61] [.e index @62]
-} {3 4}
-test entry-6.2 {EntryComputeGeometry procedure} {fonts} {
- catch {destroy .e}
- entry .e -font $fixed -bd 2 -relief raised -width 20 -justify center \
- -highlightthickness 3
+} -cleanup {
+ destroy .e
+} -result {3 4}
+test entry-6.2 {EntryComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ entry .e
pack .e
+} -body {
+ .e configure -font {Courier -12} -bd 2 -relief raised -width 20 \
+ -justify center -highlightthickness 3
.e insert end 012\t45
update
list [.e index @96] [.e index @97]
-} {3 4}
-test entry-6.3 {EntryComputeGeometry procedure} {fonts} {
- catch {destroy .e}
- entry .e -font $fixed -bd 2 -relief raised -width 20 -justify right \
- -highlightthickness 3
+} -cleanup {
+ destroy .e
+} -result {3 4}
+test entry-6.3 {EntryComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ entry .e
pack .e
+} -body {
+ .e configure -font {Courier -12} -bd 2 -relief raised -width 20 \
+ -justify right -highlightthickness 3
.e insert end 012\t45
update
list [.e index @131] [.e index @132]
-} {3 4}
-test entry-6.4 {EntryComputeGeometry procedure} {
- catch {destroy .e}
- entry .e -font $fixed -bd 2 -relief raised -width 5
+} -cleanup {
+ destroy .e
+} -result {3 4}
+test entry-6.4 {EntryComputeGeometry procedure} -setup {
+ entry .e
pack .e
+} -body {
+ .e configure -font {Courier -12} -bd 2 -relief raised -width 5
.e insert end "01234567890"
update
.e xview 6
.e index @0
-} {6}
-test entry-6.5 {EntryComputeGeometry procedure} {
- catch {destroy .e}
- entry .e -font $fixed -bd 2 -relief raised -width 5
+} -cleanup {
+ destroy .e
+} -result {6}
+test entry-6.5 {EntryComputeGeometry procedure} -setup {
+ entry .e -highlightthickness 2
pack .e
+} -body {
+ .e configure -font {Courier -12} -bd 2 -relief raised -width 5
.e insert end "01234567890"
update
.e xview 7
.e index @0
-} {6}
-test entry-6.6 {EntryComputeGeometry procedure} {fonts} {
- catch {destroy .e}
- entry .e -font $fixed -bd 2 -relief raised -width 10
+} -cleanup {
+ destroy .e
+} -result {6}
+test entry-6.6 {EntryComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ entry .e -highlightthickness 2
pack .e
+} -body {
+ .e configure -font {Courier -12} -bd 2 -relief raised -width 10
.e insert end "01234\t67890"
update
.e xview 3
list [.e index @39] [.e index @40]
-} {5 6}
-test entry-6.7 {EntryComputeGeometry procedure} {fonts} {
- catch {destroy .e}
- entry .e -font $big -bd 3 -relief raised -width 5
+} -cleanup {
+ destroy .e
+} -result {5 6}
+test entry-6.7 {EntryComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ entry .e -highlightthickness 2
pack .e
+} -body {
+ .e configure -font {Helvetica -24} -bd 3 -relief raised -width 5
.e insert end "01234567"
update
list [winfo reqwidth .e] [winfo reqheight .e]
-} {77 39}
-test entry-6.8 {EntryComputeGeometry procedure} {fonts} {
- catch {destroy .e}
- entry .e -font $big -bd 3 -relief raised -width 0
+} -cleanup {
+ destroy .e
+} -result {77 39}
+test entry-6.8 {EntryComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ entry .e -highlightthickness 2
pack .e
+} -body {
+ .e configure -font {Helvetica -24} -bd 3 -relief raised -width 0
.e insert end "01234567"
update
list [winfo reqwidth .e] [winfo reqheight .e]
-} {116 39}
-test entry-6.9 {EntryComputeGeometry procedure} {fonts} {
- catch {destroy .e}
- entry .e -font $big -bd 3 -relief raised -width 0 -highlightthickness 2
+} -cleanup {
+ destroy .e
+} -result {116 39}
+test entry-6.9 {EntryComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ entry .e -highlightthickness 2
pack .e
+} -body {
+ .e configure -font {Helvetica -24} -bd 3 -relief raised -width 0
update
list [winfo reqwidth .e] [winfo reqheight .e]
-} {25 39}
-test entry-6.10 {EntryComputeGeometry procedure} {unix fonts} {
- catch {destroy .e}
- entry .e -bd 1 -relief raised -width 0 -show .
- .e insert 0 12345
+} -cleanup {
+ destroy .e
+} -result {25 39}
+test entry-6.10 {EntryComputeGeometry procedure} -constraints {
+ unix fonts
+} -setup {
+ entry .e -highlightthickness 2 -font {Helvetica -12}
pack .e
+} -body {
+ .e configure -bd 1 -relief raised -width 0 -show .
+ .e insert 0 12345
update
set x [winfo reqwidth .e]
.e configure -show X
lappend x [winfo reqwidth .e]
.e configure -show ""
lappend x [winfo reqwidth .e]
-} {23 53 43}
-test entry-6.11 {EntryComputeGeometry procedure} win {
- catch {destroy .e}
- entry .e -bd 1 -relief raised -width 0 -show . -font {helvetica 12}
- .e insert 0 12345
+} -cleanup {
+ destroy .e
+} -result {23 53 43}
+test entry-6.11 {EntryComputeGeometry procedure} -constraints {
+ win
+} -setup {
+ entry .e -highlightthickness 2
pack .e
+} -body {
+ .e configure -bd 1 -relief raised -width 0 -show . -font {helvetica 12}
+ .e insert 0 12345
update
- set x [winfo reqwidth .e]
+ set x1 [winfo reqwidth .e]
+ set x2 [expr {8+5*[font measure {helvetica 12} .]}]
+ set x [expr {$x1 eq $x2}]
.e configure -show X
- lappend x [winfo reqwidth .e]
+ set x1 [winfo reqwidth .e]
+ set x2 [expr {8+5*[font measure {helvetica 12} X]}]
+ lappend x [expr {$x1 eq $x2}]
.e configure -show ""
- lappend x [winfo reqwidth .e]
-} [list \
- [expr 8+5*[font measure {helvetica 12} .]] \
- [expr 8+5*[font measure {helvetica 12} X]] \
- [expr 8+[font measure {helvetica 12} 12345]]]
-
-catch {destroy .e}
-entry .e -width 10 -font $fixed -textvariable contents -xscrollcommand scroll
-pack .e
-focus .e
-test entry-7.1 {InsertChars procedure} {
- .e delete 0 end
+ set x1 [winfo reqwidth .e]
+ set x2 [expr {8+[font measure {helvetica 12} 12345]}]
+ lappend x [expr {$x1 eq $x2}]
+} -cleanup {
+ destroy .e
+} -result {1 1 1}
+
+
+test entry-7.1 {InsertChars procedure} -setup {
+ unset -nocomplain contents
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e configure -textvariable contents -xscrollcommand scroll
.e insert 0 abcde
.e insert 2 XXX
update
list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
-} {abXXXcde abXXXcde {0.000000 1.000000}}
-test entry-7.2 {InsertChars procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {abXXXcde abXXXcde {0.000000 1.000000}}
+
+test entry-7.2 {InsertChars procedure} -setup {
+ unset -nocomplain contents
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e configure -textvariable contents -xscrollcommand scroll
.e insert 0 abcde
.e insert 500 XXX
update
list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
-} {abcdeXXX abcdeXXX {0.000000 1.000000}}
-test entry-7.3 {InsertChars procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {abcdeXXX abcdeXXX {0.000000 1.000000}}
+test entry-7.3 {InsertChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
.e insert 0 0123456789
.e select from 2
.e select to 6
@@ -806,9 +1934,13 @@ test entry-7.3 {InsertChars procedure} {
set x "[.e index sel.first] [.e index sel.last]"
.e select to 8
lappend x [.e index sel.first] [.e index sel.last]
-} {5 9 5 8}
-test entry-7.4 {InsertChars procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {5 9 5 8}
+test entry-7.4 {InsertChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
.e insert 0 0123456789
.e select from 2
.e select to 6
@@ -816,9 +1948,13 @@ test entry-7.4 {InsertChars procedure} {
set x "[.e index sel.first] [.e index sel.last]"
.e select to 8
lappend x [.e index sel.first] [.e index sel.last]
-} {2 9 2 8}
-test entry-7.5 {InsertChars procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {2 9 2 8}
+test entry-7.5 {InsertChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
.e insert 0 0123456789
.e select from 2
.e select to 6
@@ -826,9 +1962,13 @@ test entry-7.5 {InsertChars procedure} {
set x "[.e index sel.first] [.e index sel.last]"
.e select to 8
lappend x [.e index sel.first] [.e index sel.last]
-} {2 9 2 8}
-test entry-7.6 {InsertChars procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {2 9 2 8}
+test entry-7.6 {InsertChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
.e insert 0 0123456789
.e select from 2
.e select to 6
@@ -836,70 +1976,118 @@ test entry-7.6 {InsertChars procedure} {
set x "[.e index sel.first] [.e index sel.last]"
.e select to 5
lappend x [.e index sel.first] [.e index sel.last]
-} {2 6 2 5}
-test entry-7.7 {InsertChars procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {2 6 2 5}
+test entry-7.7 {InsertChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e configure -xscrollcommand scroll
.e insert 0 0123456789
.e icursor 4
.e insert 4 XXX
.e index insert
-} {7}
-test entry-7.8 {InsertChars procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {7}
+test entry-7.8 {InsertChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
.e insert 0 0123456789
.e icursor 4
.e insert 5 XXX
.e index insert
-} {4}
-test entry-7.9 {InsertChars procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {4}
+test entry-7.9 {InsertChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
.e insert 0 "This is a very long string"
update
.e xview 4
.e insert 3 XXX
.e index @0
-} {7}
-test entry-7.10 {InsertChars procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {7}
+test entry-7.10 {InsertChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
.e insert 0 "This is a very long string"
update
.e xview 4
.e insert 4 XXX
.e index @0
-} {4}
-.e configure -width 0
-test entry-7.11 {InsertChars procedure} {fonts} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {4}
+
+test entry-7.11 {InsertChars procedure} -constraints {
+ fonts
+} -setup {
+ entry .e -width 0 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
.e insert 0 "xyzzy"
update
.e insert 2 00
winfo reqwidth .e
-} {59}
+} -cleanup {
+ destroy .e
+} -result {59}
-.e configure -width 10
-test entry-8.1 {DeleteChars procedure} {
- .e delete 0 end
+test entry-8.1 {DeleteChars procedure} -setup {
+ unset -nocomplain contents
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e configure -textvariable contents -xscrollcommand scroll
.e insert 0 abcde
.e delete 2 4
update
list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
-} {abe abe {0.000000 1.000000}}
-test entry-8.2 {DeleteChars procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {abe abe {0.000000 1.000000}}
+test entry-8.2 {DeleteChars procedure} -setup {
+ unset -nocomplain contents
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e configure -textvariable contents -xscrollcommand scroll
.e insert 0 abcde
.e delete -2 2
update
list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
-} {cde cde {0.000000 1.000000}}
-test entry-8.3 {DeleteChars procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {cde cde {0.000000 1.000000}}
+test entry-8.3 {DeleteChars procedure} -setup {
+ unset -nocomplain contents
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
+ .e configure -textvariable contents -xscrollcommand scroll
.e insert 0 abcde
.e delete 3 1000
update
list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
-} {abc abc {0.000000 1.000000}}
-test entry-8.4 {DeleteChars procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {abc abc {0.000000 1.000000}}
+test entry-8.4 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
.e insert 0 0123456789abcde
.e select from 3
.e select to 8
@@ -908,9 +2096,14 @@ test entry-8.4 {DeleteChars procedure} {
set x "[.e index sel.first] [.e index sel.last]"
.e select to 5
lappend x [.e index sel.first] [.e index sel.last]
-} {1 6 1 5}
-test entry-8.5 {DeleteChars procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {1 6 1 5}
+test entry-8.5 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
.e insert 0 0123456789abcde
.e select from 3
.e select to 8
@@ -919,9 +2112,14 @@ test entry-8.5 {DeleteChars procedure} {
set x "[.e index sel.first] [.e index sel.last]"
.e select to 4
lappend x [.e index sel.first] [.e index sel.last]
-} {1 5 1 4}
-test entry-8.6 {DeleteChars procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {1 5 1 4}
+test entry-8.6 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
.e insert 0 0123456789abcde
.e select from 3
.e select to 8
@@ -930,17 +2128,28 @@ test entry-8.6 {DeleteChars procedure} {
set x "[.e index sel.first] [.e index sel.last]"
.e select to 5
lappend x [.e index sel.first] [.e index sel.last]
-} {1 2 1 5}
-test entry-8.7 {DeleteChars procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {1 2 1 5}
+test entry-8.7 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
.e insert 0 0123456789abcde
.e select from 3
.e select to 8
.e delete 1 8
- list [catch {.e index sel.first} msg] $msg
-} {1 {selection isn't in widget .e}}
-test entry-8.8 {DeleteChars procedure} {
- .e delete 0 end
+ update
+ .e index sel.first
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {selection isn't in widget .e}
+test entry-8.8 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
.e insert 0 0123456789abcde
.e select from 3
.e select to 8
@@ -949,17 +2158,27 @@ test entry-8.8 {DeleteChars procedure} {
set x "[.e index sel.first] [.e index sel.last]"
.e select to 8
lappend x [.e index sel.first] [.e index sel.last]
-} {3 4 3 8}
-test entry-8.9 {DeleteChars procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {3 4 3 8}
+test entry-8.9 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
.e insert 0 0123456789abcde
.e select from 3
.e select to 8
.e delete 3 8
- list [catch {.e index sel.first} msg] $msg
-} {1 {selection isn't in widget .e}}
-test entry-8.10 {DeleteChars procedure} {
- .e delete 0 end
+ update
+ .e index sel.first
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {selection isn't in widget .e}
+test entry-8.10 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
.e insert 0 0123456789abcde
.e select from 8
.e select to 3
@@ -968,9 +2187,14 @@ test entry-8.10 {DeleteChars procedure} {
set x "[.e index sel.first] [.e index sel.last]"
.e select to 8
lappend x [.e index sel.first] [.e index sel.last]
-} {3 5 5 8}
-test entry-8.11 {DeleteChars procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {3 5 5 8}
+test entry-8.11 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
.e insert 0 0123456789abcde
.e select from 8
.e select to 3
@@ -979,124 +2203,186 @@ test entry-8.11 {DeleteChars procedure} {
set x "[.e index sel.first] [.e index sel.last]"
.e select to 4
lappend x [.e index sel.first] [.e index sel.last]
-} {3 8 4 8}
-test entry-8.12 {DeleteChars procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {3 8 4 8}
+test entry-8.12 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
.e insert 0 0123456789abcde
.e icursor 4
.e delete 1 4
+ update
.e index insert
-} {1}
-test entry-8.13 {DeleteChars procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {1}
+test entry-8.13 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
.e insert 0 0123456789abcde
.e icursor 4
.e delete 1 5
+ update
.e index insert
-} {1}
-test entry-8.14 {DeleteChars procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {1}
+test entry-8.14 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
.e insert 0 0123456789abcde
.e icursor 4
.e delete 4 6
+ update
.e index insert
-} {4}
-test entry-8.15 {DeleteChars procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {4}
+test entry-8.15 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
.e insert 0 "This is a very long string"
.e xview 4
.e delete 1 4
+ update
.e index @0
-} {1}
-test entry-8.16 {DeleteChars procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {1}
+test entry-8.16 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
.e insert 0 "This is a very long string"
.e xview 4
.e delete 1 5
+ update
.e index @0
-} {1}
-test entry-8.17 {DeleteChars procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {1}
+test entry-8.17 {DeleteChars procedure} -setup {
+ entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
.e insert 0 "This is a very long string"
.e xview 4
.e delete 4 6
+ update
.e index @0
-} {4}
-.e configure -width 0
-test entry-8.18 {DeleteChars procedure} {fonts} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {4}
+test entry-8.18 {DeleteChars procedure} -setup {
+ entry .e -width 0 -font {Courier -12} -highlightthickness 2 -bd 2
+ pack .e
+ focus .e
+} -body {
.e insert 0 "xyzzy"
update
.e delete 2 4
winfo reqwidth .e
-} {31}
+} -cleanup {
+ destroy .e
+} -result {31}
-test entry-9.1 {EntryValueChanged procedure} {
- catch {destroy .e}
- proc override args {
- global x
- set x 12345
- }
- catch {unset x}
+test entry-9.1 {EntryValueChanged procedure} -setup {
+ unset -nocomplain x
+} -body {
trace variable x w override
- entry .e -textvariable x
+ entry .e -textvariable x -width 0
.e insert 0 foo
- set result [list $x [.e get]]
- unset x; rename override {}
- set result
-} {12345 12345}
-
-catch {destroy .e}
-entry .e
-pack .e
-.e configure -width 0
-test entry-10.1 {EntrySetValue procedure} {fonts} {
+ list $x [.e get]
+} -cleanup {
+ destroy .e
+ trace vdelete x w override
+ unset x
+} -result {12345 12345}
+
+
+test entry-10.1 {EntrySetValue procedure} -constraints fonts -body {
set x abcde
set y ab
- .e configure -textvariable x
- update
+ entry .e -font {Helvetica -12} -highlightthickness 2 -bd 2 -width 0
+ pack .e
+ .e configure -textvariable x
.e configure -textvariable y
update
list [.e get] [winfo reqwidth .e]
-} {ab 24}
-test entry-10.2 {EntrySetValue procedure, updating selection} {
- catch {destroy .e}
- entry .e -textvariable x
+} -cleanup {
+ destroy .e
+} -result {ab 24}
+test entry-10.2 {EntrySetValue procedure, updating selection} -setup {
+ unset -nocomplain x
+ entry .e -font {Helvetica -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e configure -textvariable x
.e insert 0 "abcdefghjklmnopqrstu"
.e selection range 4 10
set x "a"
- list [catch {.e index sel.first} msg] $msg
-} {1 {selection isn't in widget .e}}
-test entry-10.3 {EntrySetValue procedure, updating selection} {
- catch {destroy .e}
- entry .e -textvariable x
+ .e index sel.first
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {selection isn't in widget .e}
+test entry-10.3 {EntrySetValue procedure, updating selection} -setup {
+ unset -nocomplain x
+ entry .e -font {Helvetica -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e configure -textvariable x
.e insert 0 "abcdefghjklmnopqrstu"
.e selection range 4 10
set x "abcdefg"
list [.e index sel.first] [.e index sel.last]
-} {4 7}
-test entry-10.4 {EntrySetValue procedure, updating selection} {
- catch {destroy .e}
- entry .e -textvariable x
+} -cleanup {
+ destroy .e
+} -result {4 7}
+test entry-10.4 {EntrySetValue procedure, updating selection} -setup {
+ unset -nocomplain x
+ entry .e -font {Helvetica -12} -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e configure -textvariable x
.e insert 0 "abcdefghjklmnopqrstu"
.e selection range 4 10
set x "abcdefghijklmn"
list [.e index sel.first] [.e index sel.last]
-} {4 10}
-test entry-10.5 {EntrySetValue procedure, updating display position} {
- catch {destroy .e}
- entry .e -width 10 -font $fixed -textvariable x
+} -cleanup {
+ destroy .e
+} -result {4 10}
+test entry-10.5 {EntrySetValue procedure, updating display position} -setup {
+ unset -nocomplain x
+ entry .e -highlightthickness 2 -bd 2
pack .e
+} -body {
+ .e configure -width 10 -font {Courier -12} -textvariable x
.e insert 0 "abcdefghjklmnopqrstuvwxyz"
.e xview 10
update
set x "abcdefg"
update
.e index @0
-} {0}
-test entry-10.6 {EntrySetValue procedure, updating display position} {
- catch {destroy .e}
- entry .e -width 10 -font $fixed -textvariable x
+} -cleanup {
+ destroy .e
+} -result {0}
+test entry-10.6 {EntrySetValue procedure, updating display position} -setup {
+ unset -nocomplain x
+ entry .e -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e configure -width 10 -font {Courier -12} -textvariable x
pack .e
.e insert 0 "abcdefghjklmnopqrstuvwxyz"
.e xview 10
@@ -1104,192 +2390,472 @@ test entry-10.6 {EntrySetValue procedure, updating display position} {
set x "1234567890123456789012"
update
.e index @0
-} {10}
-test entry-10.7 {EntrySetValue procedure, updating insertion cursor} {
- catch {destroy .e}
- entry .e -width 10 -font $fixed -textvariable x
+} -cleanup {
+ destroy .e
+} -result {10}
+test entry-10.7 {EntrySetValue procedure, updating insertion cursor} -setup {
+ unset -nocomplain x
+ entry .e -highlightthickness 2 -bd 2
+ pack .e
+ update
+} -body {
+ .e configure -width 10 -font {Courier -12} -textvariable x
pack .e
.e insert 0 "abcdefghjklmnopqrstuvwxyz"
.e icursor 5
set x "123"
.e index insert
-} {3}
-test entry-10.8 {EntrySetValue procedure, updating insertion cursor} {
- catch {destroy .e}
- entry .e -width 10 -font $fixed -textvariable x
+} -cleanup {
+ destroy .e
+} -result {3}
+test entry-10.8 {EntrySetValue procedure, updating insertion cursor} -setup {
+ unset -nocomplain x
+ entry .e -highlightthickness 2 -bd 2
+ pack .e
+} -body {
+ .e configure -width 10 -font {Courier -12} -textvariable x
pack .e
.e insert 0 "abcdefghjklmnopqrstuvwxyz"
.e icursor 5
set x "123456"
.e index insert
-} {5}
+} -cleanup {
+ destroy .e
+} -result {5}
-test entry-11.1 {EntryEventProc procedure} {
- catch {destroy .e}
- entry .e
+test entry-11.1 {EntryEventProc procedure} -setup {
+ entry .e -highlightthickness 2 -bd 2 -font {Helvetica -12}
+ pack .e
+} -body {
.e insert 0 abcdefg
destroy .e
update
-} {}
-test entry-11.2 {EntryEventProc procedure} {
- deleteWindows
+} -cleanup {
+ destroy .e
+} -result {}
+test entry-11.2 {EntryEventProc procedure} -setup {
+ set x {}
+} -body {
entry .e1 -fg #112233
rename .e1 .e2
- set x {}
lappend x [winfo children .]
lappend x [.e2 cget -fg]
destroy .e1
lappend x [info command .e*] [winfo children .]
-} {.e1 #112233 {} {}}
-
-test entry-12.1 {EntryCmdDeletedProc procedure} {
- deleteWindows
- button .e1 -text "xyz_123"
- rename .e1 {}
- list [info command .e*] [winfo children .]
-} {{} {}}
-
-catch {destroy .e}
-entry .e -font $fixed -width 5 -bd 2 -relief sunken
-pack .e
-.e insert 0 012345678901234567890
-.e xview 4
-update
-test entry-13.1 {GetEntryIndex procedure} {
+} -cleanup {
+ destroy .e1
+} -result {.e1 #112233 {} {}}
+
+test entry-12.1 {EntryCmdDeletedProc procedure} -body {
+ button .b -text "xyz_123"
+ rename .b {}
+ list [info command .b*] [winfo children .]
+} -cleanup {
+ destroy .b
+} -result {{} {}}
+
+
+test entry-13.1 {GetEntryIndex procedure} -setup {
+ entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+} -body {
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
.e index end
-} {21}
-test entry-13.2 {GetEntryIndex procedure} {
- list [catch {.e index abogus} msg] $msg
-} {1 {bad entry index "abogus"}}
-test entry-13.3 {GetEntryIndex procedure} {
+} -cleanup {
+ destroy .e
+} -result {21}
+test entry-13.2 {GetEntryIndex procedure} -body {
+ entry .e
+ .e index abogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "abogus"}
+test entry-13.3 {GetEntryIndex procedure} -setup {
+ entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+} -body {
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
.e select from 1
.e select to 6
.e index anchor
-} {1}
-test entry-13.4 {GetEntryIndex procedure} {
+} -cleanup {
+ destroy .e
+} -result {1}
+test entry-13.4 {GetEntryIndex procedure} -setup {
+ entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+} -body {
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
.e select from 4
.e select to 1
.e index anchor
-} {4}
-test entry-13.5 {GetEntryIndex procedure} {
+} -cleanup {
+ destroy .e
+} -result {4}
+test entry-13.5 {GetEntryIndex procedure} -setup {
+ entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+} -body {
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
.e select from 3
.e select to 15
.e select adjust 4
.e index anchor
-} {15}
-test entry-13.6 {GetEntryIndex procedure} {
- list [catch {.e index ebogus} msg] $msg
-} {1 {bad entry index "ebogus"}}
-test entry-13.7 {GetEntryIndex procedure} {
+} -cleanup {
+ destroy .e
+} -result {15}
+test entry-13.6 {GetEntryIndex procedure} -setup {
+ entry .e
+} -body {
+ .e index ebogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "ebogus"}
+test entry-13.7 {GetEntryIndex procedure} -setup {
+ entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+} -body {
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
.e icursor 2
.e index insert
-} {2}
-test entry-13.8 {GetEntryIndex procedure} {
- list [catch {.e index ibogus} msg] $msg
-} {1 {bad entry index "ibogus"}}
-test entry-13.9 {GetEntryIndex procedure} {
+} -cleanup {
+ destroy .e
+} -result {2}
+test entry-13.8 {GetEntryIndex procedure} -setup {
+ entry .e
+} -body {
+ .e index ibogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "ibogus"}
+test entry-13.9 {GetEntryIndex procedure} -setup {
+ entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+} -body {
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {1 6}
+
+
+
+
+
+
+test entry-13.10 {GetEntryIndex procedure} -constraints unix -body {
+# On unix, when selection is cleared, entry widget's internal
+# selection range is reset.
+# Previous settings:
+ entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+# Testing:
+ selection clear .e
+ .e index sel.first
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {selection isn't in widget .e}
+
+test entry-13.11 {GetEntryIndex procedure} -constraints win -body {
+# On mac and pc, when selection is cleared, entry widget remembers
+# last selected range. When selection ownership is restored to
+# entry, the old range will be rehighlighted.
+# Previous settings:
+ entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+# Testing:
+ selection clear .e
+ catch {selection get}
+ .e index sel.first
+} -cleanup {
+ destroy .e
+} -result {1}
+
+test entry-13.12 {GetEntryIndex procedure} -constraints unix -body {
+# Previous settings:
+ entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+# Testing:
+ selection clear .e
+ .e index sbogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {selection isn't in widget .e}
+
+# why when string in .e index changed to not beginning with s,
+# it behaves differently?
+test entry-13.12.1 {GetEntryIndex procedure} -constraints unix -body {
+# Previous settings:
+ entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+# Testing:
+ selection clear .e
+ .e index bogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "bogus"}
+
+test entry-13.13 {GetEntryIndex procedure} -constraints win -body {
+# Previous settings:
+ entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+# Testing:
+ selection clear .e
+ .e index sbogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "sbogus"}
+
+test entry-13.14 {GetEntryIndex procedure} -constraints win -body {
+# On mac and pc, when selection is cleared, entry widget remembers
+# last selected range. When selection ownership is restored to
+# entry, the old range will be rehighlighted.
+# Previous settings:
+ entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+# Testing:
+ selection clear .e
+ selection get
+} -cleanup {
+ destroy .e
+} -returnCodes error -match glob -result {*}
+
+test entry-13.14.1 {GetEntryIndex procedure} -constraints win -body {
+# On mac and pc, when selection is cleared, entry widget remembers
+# last selected range. When selection ownership is restored to
+# entry, the old range will be rehighlighted.
+# Previous settings:
+ entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
.e select from 1
.e select to 6
list [.e index sel.first] [.e index sel.last]
-} {1 6}
-selection clear .e
-test entry-13.10 {GetEntryIndex procedure} unix {
- # On unix, when selection is cleared, entry widget's internal
- # selection range is reset.
-
- list [catch {.e index sel.first} msg] $msg
-} {1 {selection isn't in widget .e}}
-test entry-13.11 {GetEntryIndex procedure} win {
- # On mac and pc, when selection is cleared, entry widget remembers
- # last selected range. When selection ownership is restored to
- # entry, the old range will be rehighlighted.
-
- list [catch {selection get}] [.e index sel.first]
-} {1 1}
-test entry-13.12 {GetEntryIndex procedure} unix {
- list [catch {.e index sbogus} msg] $msg
-} {1 {selection isn't in widget .e}}
-test entry-13.13 {GetEntryIndex procedure} win {
- list [catch {.e index sbogus} msg] $msg
-} {1 {bad entry index "sbogus"}}
-test entry-13.14 {GetEntryIndex procedure} win {
- list [catch {selection get}] [catch {.e index sbogus}]
-} {1 1}
-test entry-13.15 {GetEntryIndex procedure} {
- list [catch {.e index @xyz} msg] $msg
-} {1 {bad entry index "@xyz"}}
-test entry-13.16 {GetEntryIndex procedure} {fonts} {
+# Testing:
+ selection clear .e
+ catch {selection get}
+ .e index sbogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -match glob -result {*}
+
+test entry-13.15 {GetEntryIndex procedure} -body {
+ entry .e
+ selection clear .e
+ .e index @xyz
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "@xyz"}
+
+test entry-13.16 {GetEntryIndex procedure} -constraints fonts -body {
+ entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
.e index @4
-} {4}
-test entry-13.17 {GetEntryIndex procedure} {fonts} {
+} -cleanup {
+ destroy .e
+} -result {4}
+test entry-13.17 {GetEntryIndex procedure} -constraints fonts -body {
+ entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
.e index @11
-} {4}
-test entry-13.18 {GetEntryIndex procedure} {fonts} {
+} -cleanup {
+ destroy .e
+} -result {4}
+test entry-13.18 {GetEntryIndex procedure} -constraints fonts -body {
+ entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
.e index @12
-} {5}
-test entry-13.19 {GetEntryIndex procedure} {fonts} {
- .e index @[expr [winfo width .e] - 6]
-} {8}
-test entry-13.20 {GetEntryIndex procedure} {fonts} {
- .e index @[expr [winfo width .e] - 5]
-} {9}
-test entry-13.21 {GetEntryIndex procedure} {
+} -cleanup {
+ destroy .e
+} -result {5}
+test entry-13.19 {GetEntryIndex procedure} -constraints fonts -body {
+ entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e index @[expr {[winfo width .e] - 6}]
+} -cleanup {
+ destroy .e
+} -result {8}
+test entry-13.20 {GetEntryIndex procedure} -constraints fonts -body {
+ entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e index @[expr {[winfo width .e] - 5}]
+} -cleanup {
+ destroy .e
+} -result {9}
+test entry-13.21 {GetEntryIndex procedure} -body {
+ entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
.e index @1000
-} {9}
-test entry-13.22 {GetEntryIndex procedure} {
- list [catch {.e index 1xyz} msg] $msg
-} {1 {bad entry index "1xyz"}}
-test entry-13.23 {GetEntryIndex procedure} {
+} -cleanup {
+ destroy .e
+} -result {9}
+test entry-13.22 {GetEntryIndex procedure} -setup {
+ entry .e
+ pack .e
+ update
+} -body {
+ .e index 1xyz
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad entry index "1xyz"}
+test entry-13.23 {GetEntryIndex procedure} -body {
+ entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
.e index -10
-} {0}
-test entry-13.24 {GetEntryIndex procedure} {
+} -cleanup {
+ destroy .e
+} -result {0}
+test entry-13.24 {GetEntryIndex procedure} -body {
+ entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
.e index 12
-} {12}
-test entry-13.25 {GetEntryIndex procedure} {
+} -cleanup {
+ destroy .e
+} -result {12}
+test entry-13.25 {GetEntryIndex procedure} -body {
+ entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
.e index 49
-} {21}
-test entry-13.26 {GetEntryIndex procedure} {fonts} {
- catch {destroy .e}
- entry .e -show .
+} -cleanup {
+ destroy .e
+} -result {21}
+test entry-13.26 {GetEntryIndex procedure} -constraints fonts -body {
+ entry .e -highlightthickness 2 -bd 2 -font {Helvetica -12}
+ selection clear .e
+ .e configure -show .
.e insert 0 XXXYZZY
pack .e
update
list [.e index @7] [.e index @8]
-} {0 1}
+} -cleanup {
+ destroy .e
+} -result {0 1}
# XXX Still need to write tests for EntryScanTo and EntrySelectTo.
-set x {}
-for {set i 1} {$i <= 500} {incr i} {
- append x "This is line $i, out of 500\n"
-}
-test entry-14.1 {EntryFetchSelection procedure} {
- catch {destroy .e}
+
+test entry-14.1 {EntryFetchSelection procedure} -body {
entry .e
.e insert end "This is a test string"
.e select from 1
.e select to 18
selection get
-} {his is a test str}
-test entry-14.2 {EntryFetchSelection procedure} {
- catch {destroy .e}
+} -cleanup {
+ destroy .e
+} -result {his is a test str}
+test entry-14.2 {EntryFetchSelection procedure} -body {
entry .e -show *
.e insert end "This is a test string"
.e select from 1
.e select to 18
selection get
-} {*****************}
-test entry-14.3 {EntryFetchSelection procedure} {
- catch {destroy .e}
+} -cleanup {
+ destroy .e
+} -result {*****************}
+test entry-14.3 {EntryFetchSelection procedure} -setup {
+ set x {}
+ for {set i 1} {$i <= 500} {incr i} {
+ append x "This is line $i, out of 500\n"
+}
+} -body {
entry .e
- .e insert end $x
+ .e insert end $x
.e select from 0
.e select to end
string compare [selection get] $x
-} 0
+} -cleanup {
+ destroy .e
+} -result {0}
-test entry-15.1 {EntryLostSelection} {
- catch {destroy .e}
+test entry-15.1 {EntryLostSelection} -body {
entry .e
.e insert 0 "Text"
.e select from 0
@@ -1299,334 +2865,617 @@ test entry-15.1 {EntryLostSelection} {
.e select from 0
.e select to 4
lappend result [selection get]
-} {Text Text}
-
-# No tests for EventuallyRedraw.
-
-catch {destroy .e}
-entry .e -width 10 -xscrollcommand scroll
-pack .e
-update
+} -cleanup {
+ destroy .e
+} -result {Text Text}
-test entry-16.1 {EntryVisibleRange procedure} {fonts} {
- .e delete 0 end
- .e insert 0 .............................
+# is scrollcommand needed here??
+test entry-16.1 {EntryVisibleRange procedure} -constraints fonts -body {
+ entry .e -width 10 -font {Helvetica -12}
+ pack .e
+ update
+ .e insert 0 "............................."
format {%.6f %.6f} {*}[.e xview]
-} {0.000000 0.827586}
-test entry-16.2 {EntryVisibleRange procedure} {unix fonts} {
- .e configure -show X
- .e delete 0 end
- .e insert 0 .............................
+} -cleanup {
+ destroy .e
+} -result {0.000000 0.827586}
+test entry-16.2 {EntryVisibleRange procedure} -constraints {
+ unix fonts
+} -body {
+ entry .e -show X -width 10 -font {Helvetica -12}
+ pack .e
+ update
+ .e insert 0 "............................."
format {%.6f %.6f} {*}[.e xview]
-} {0.000000 0.275862}
-test entry-16.3 {EntryVisibleRange procedure} win {
- .e configure -show .
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {0.000000 0.275862}
+test entry-16.3 {EntryVisibleRange procedure} -constraints {
+ win
+} -body {
+ entry .e -show . -width 10 -font {Helvetica -12}
+ pack .e
+ update
.e insert 0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXX
format {%.6f %.6f} {*}[.e xview]
-} {0.000000 0.827586}
-.e configure -show ""
-test entry-16.4 {EntryVisibleRange procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {0.000000 0.827586}
+test entry-16.4 {EntryVisibleRange procedure} -body {
+ entry .e -show ""
format {%.6f %.6f} {*}[.e xview]
-} {0.000000 1.000000}
+} -cleanup {
+ destroy .e
+} -result {0.000000 1.000000}
+
-catch {destroy .e}
-entry .e -width 10 -xscrollcommand scroll -font $fixed
-pack .e
-update
-test entry-17.1 {EntryUpdateScrollbar procedure} {
+test entry-17.1 {EntryUpdateScrollbar procedure} -body {
+ entry .e -width 10 -xscrollcommand scroll -font {Courier -12}
+ pack .e
.e delete 0 end
.e insert 0 123
update
format {%.6f %.6f} {*}$scrollInfo
-} {0.000000 1.000000}
-test entry-17.2 {EntryUpdateScrollbar procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {0.000000 1.000000}
+test entry-17.2 {EntryUpdateScrollbar procedure} -body {
+ entry .e -width 10 -xscrollcommand scroll -font {Courier -12}
+ pack .e
.e insert 0 0123456789abcdef
.e xview 3
update
format {%.6f %.6f} {*}$scrollInfo
-} {0.187500 0.812500}
-test entry-17.3 {EntryUpdateScrollbar procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {0.187500 0.812500}
+test entry-17.3 {EntryUpdateScrollbar procedure} -body {
+ entry .e -width 10 -xscrollcommand scroll -font {Courier -12}
+ pack .e
.e insert 0 abcdefghijklmnopqrs
.e xview 6
update
format {%.6f %.6f} {*}$scrollInfo
-} {0.315789 0.842105}
-test entry-17.4 {EntryUpdateScrollbar procedure} {
+} -cleanup {
destroy .e
+} -result {0.315789 0.842105}
+test entry-17.4 {EntryUpdateScrollbar procedure} -setup {
proc bgerror msg {
global x
set x $msg
- }
+}
+} -body {
entry .e -width 5 -xscrollcommand thisisnotacommand
pack .e
update
- rename bgerror {}
list $x $errorInfo
-} {{invalid command name "thisisnotacommand"} {invalid command name "thisisnotacommand"
+} -cleanup {
+ destroy .e
+ rename bgerror {}
+} -result {{invalid command name "thisisnotacommand"} {invalid command name "thisisnotacommand"
while executing
"thisisnotacommand 0.0 1.0"
(horizontal scrolling command executed by .e)}}
-set l [interp hidden]
-deleteWindows
-test entry-18.1 {Entry widget vs hiding} {
- destroy .e
+test entry-18.1 {Entry widget vs hiding} -setup {
entry .e
+} -body {
+ set l [interp hidden]
interp hide {} .e
destroy .e
- list [winfo children .] [interp hidden]
-} [list {} $l]
+ set res1 [list [winfo children .] [interp hidden]]
+ set res2 [list {} $l]
+ expr {$res1 == $res2}
+} -result {1}
##
## Entry widget VALIDATION tests
##
-
-destroy .e
-catch {unset ::e}
-catch {unset ::vVals}
-entry .e -validate all \
- -validatecommand [list doval %W %d %i %P %s %S %v %V] \
- -invalidcommand bell \
- -textvariable ::e \
- -background red -foreground white
-pack .e
-proc doval {W d i P s S v V} {
- set ::vVals [list $W $d $i $P $s $S $v $V]
- return 1
-}
-
# The validation tests build each one upon the previous, so cascading
# failures aren't good
#
-test entry-19.1 {entry widget validation} {
+
+# 19.* test cases in previous version highly depended on the previous
+# test cases. This was replaced by inserting recently set configurations
+# that matters for the test case
+test entry-19.1 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
.e insert 0 a
- set ::vVals
-} {.e 1 0 a {} a all key}
-test entry-19.2 {entry widget validation} {
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {.e 1 0 a {} a all key}
+
+test entry-19.2 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert 0 a ;# previous settings
.e insert 1 b
- set ::vVals
-} {.e 1 1 ab a b all key}
-test entry-19.3 {entry widget validation} {
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {.e 1 1 ab a b all key}
+
+test entry-19.3 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert 0 ab ;# previous settings
.e insert end c
- set ::vVals
-} {.e 1 2 abc ab c all key}
-test entry-19.4 {entry widget validation} {
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {.e 1 2 abc ab c all key}
+
+test entry-19.4 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert 0 abc ;# previous settings
.e insert 1 123
list $::vVals $::e
-} {{.e 1 1 a123bc abc 123 all key} a123bc}
-test entry-19.5 {entry widget validation} {
+} -cleanup {
+ destroy .e
+} -result {{.e 1 1 a123bc abc 123 all key} a123bc}
+
+test entry-19.5 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert 0 a123bc ;# previous settings
.e delete 2
- set ::vVals
-} {.e 0 2 a13bc a123bc 2 all key}
-test entry-19.6 {entry widget validation} {
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {.e 0 2 a13bc a123bc 2 all key}
+
+test entry-19.6 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert 0 a13bc ;# previous settings
.e configure -validate key
.e delete 1 3
- set ::vVals
-} {.e 0 1 abc a13bc 13 key key}
-test entry-19.7 {entry widget validation} {
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {.e 0 1 abc a13bc 13 key key}
+
+test entry-19.7 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate focus \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abc ;# previous settings
set ::vVals {}
- .e configure -validate focus
.e insert end d
- set ::vVals
-} {}
-test entry-19.8 {entry widget validation} {
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {}
+
+test entry-19.8 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e configure -validate focus ;# previous settings
+ .e insert end abcd ;# previous settings
focus -force .e
- # update necessary to process FocusIn event
+# update necessary to process FocusIn event
update
- set ::vVals
-} {.e -1 -1 abcd abcd {} focus focusin}
-test entry-19.9 {entry widget validation} {
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {.e -1 -1 abcd abcd {} focus focusin}
+
+test entry-19.9 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate focus \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
+ focus -force .e ;# previous settings
+ update ;# previous settings
+# update necessary to process FocusIn event
focus -force .
- # update necessary to process FocusOut event
+# update necessary to process FocusOut event
update
- set ::vVals
-} {.e -1 -1 abcd abcd {} focus focusout}
-.e configure -validate all
-test entry-19.10 {entry widget validation} {
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {.e -1 -1 abcd abcd {} focus focusout}
+
+test entry-19.10 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
focus -force .e
- # update necessary to process FocusIn event
+# update necessary to process FocusIn event
update
- set ::vVals
-} {.e -1 -1 abcd abcd {} all focusin}
-test entry-19.11 {entry widget validation} {
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {.e -1 -1 abcd abcd {} all focusin}
+
+test entry-19.11 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
+ focus -force .e ;# previous settings
+# update necessary to process FocusIn event
+ update ;# previous settings
focus -force .
- # update necessary to process FocusOut event
+# update necessary to process FocusOut event
update
- set ::vVals
-} {.e -1 -1 abcd abcd {} all focusout}
-.e configure -validate focusin
-test entry-19.12 {entry widget validation} {
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {.e -1 -1 abcd abcd {} all focusout}
+
+test entry-19.12 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate focusin \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert 0 abcd ;# previous settings
focus -force .e
- # update necessary to process FocusIn event
+# update necessary to process FocusIn event
update
- set ::vVals
-} {.e -1 -1 abcd abcd {} focusin focusin}
-test entry-19.13 {entry widget validation} {
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {.e -1 -1 abcd abcd {} focusin focusin}
+
+test entry-19.13 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate focusin \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
set ::vVals {}
focus -force .
- # update necessary to process FocusOut event
+# update necessary to process FocusOut event
update
- set ::vVals
-} {}
-.e configure -validate focuso
-test entry-19.14 {entry widget validation} {
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {}
+
+test entry-19.14 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate focuso \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
+ set ::vVals {} ;# previous settings
focus -force .e
- # update necessary to process FocusIn event
+# update necessary to process FocusIn event
update
- set ::vVals
-} {}
-test entry-19.15 {entry widget validation} {
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {}
+
+test entry-19.15 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate focuso \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
+ set ::vVals {} ;# previous settings
+ focus -force .e ;# previous settings
+# update necessary to process FocusIn event
+ update ;# previous settings
focus -force .
- # update necessary to process FocusOut event
+# update necessary to process FocusOut event
+ update
+ return $::vVals
+} -cleanup {
+ destroy .e
+} -result {.e -1 -1 abcd abcd {} focusout focusout}
+
+# the same as 19.16 but added [.e validate] to returned list
+test entry-19.16 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate focuso \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
+ set ::vVals {} ;# previous settings
+ focus -force .e ;# previous settings
+# update necessary to process FocusIn event
+ update ;# previous settings
+ focus -force .
+# update necessary to process FocusOut event
update
- set ::vVals
-} {.e -1 -1 abcd abcd {} focusout focusout}
-test entry-19.16 {entry widget validation} {
list [.e validate] $::vVals
-} {1 {.e -1 -1 abcd abcd {} all forced}}
-test entry-19.17 {entry widget validation} {
+} -cleanup {
+ destroy .e
+} -result {1 {.e -1 -1 abcd abcd {} all forced}}
+
+
+test entry-19.17 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate focuso \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
set ::e newdata
list [.e cget -validate] $::vVals
-} {focusout {.e -1 -1 newdata abcd {} focusout forced}}
+} -cleanup {
+ destroy .e
+} -result {focusout {.e -1 -1 newdata abcd {} focusout forced}}
-proc doval {W d i P s S v V} {
- set ::vVals [list $W $d $i $P $s $S $v $V]
- return 0
-}
-test entry-19.18 {entry widget validation} {
+# proc doval changed - returns 0
+test entry-19.18 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate all \
+ -validatecommand [list doval3 %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ set ::e newdata ;# previous settings
.e configure -validate all
set ::e nextdata
list [.e cget -validate] $::vVals
-} {none {.e -1 -1 nextdata newdata {} all forced}}
-
-proc doval {W d i P s S v V} {
- set ::vVals [list $W $d $i $P $s $S $v $V]
- set ::e mydata
- return 1
-}
+} -cleanup {
+ destroy .e
+} -result {none {.e -1 -1 nextdata newdata {} all forced}}
## This sets validate to none because it shows that we prevent a possible
## loop condition in the validation, when the entry textvar is also set
-test entry-19.19 {entry widget validation} {
- .e configure -validate all
+# proc doval2 used
+test entry-19.19 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate all \
+ -validatecommand [list doval3 %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ set ::e nextdata ;# previous settings
+
+ .e configure -validatecommand [list doval2 %W %d %i %P %s %S %v %V]
.e validate
list [.e cget -validate] [.e get] $::vVals
-} {none mydata {.e -1 -1 nextdata nextdata {} all forced}}
+} -cleanup {
+ destroy .e
+} -result {none mydata {.e -1 -1 nextdata nextdata {} all forced}}
## This leaves validate alone because we trigger validation through the
## textvar (a write trace), and the write during validation triggers
## nothing (by definition of avoiding loops on var traces). This is
## one of those "dangerous" conditions where the user will have a
## different value in the entry widget shown as is in the textvar.
-test entry-19.20 {entry widget validation} {
+test entry-19.20 {entry widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ entry .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ set ::e nextdata ;# previous settings
+ .e configure -validatecommand [list doval2 %W %d %i %P %s %S %v %V] ;# prev
+ .e validate ;# previous settings
+
.e configure -validate all
set ::e testdata
list [.e cget -validate] [.e get] $::e $::vVals
-} {all testdata mydata {.e -1 -1 testdata mydata {} all forced}}
-
-destroy .e
-catch {unset ::e ::vVals}
-
+} -cleanup {
+ destroy .e
+} -result {all testdata mydata {.e -1 -1 testdata mydata {} all forced}}
##
## End validation tests
##
-test entry-20.1 {widget deletion while active} {
- destroy .e
+test entry-20.1 {widget deletion while active} -body {
entry .e -validate all \
-validatecommand { destroy %W ; return 1 } \
-invalidcommand bell
update
.e insert 0 abc
winfo exists .e
-} 0
-test entry-20.2 {widget deletion while active} {
+} -cleanup {
destroy .e
+} -result {0}
+
+test entry-20.2 {widget deletion while active} -body {
entry .e -validate all \
-validatecommand { return 0 } \
-invalidcommand { destroy %W }
.e insert 0 abc
winfo exists .e
-} 0
-test entry-20.3 {widget deletion while active} {
+} -cleanup {
destroy .e
+} -result {0}
+
+test entry-20.3 {widget deletion while active} -body {
entry .e -validate all \
-validatecommand { rename .e {} ; return 1 }
.e insert 0 abc
winfo exists .e
-} 0
-test entry-20.4 {widget deletion while active} {
+} -cleanup {
destroy .e
+} -result {0}
+
+test entry-20.4 {widget deletion while active} -body {
entry .e -validate all \
-validatecommand { return 0 } \
-invalidcommand { rename .e {} }
.e insert 0 abc
winfo exists .e
-} 0
-test entry-20.5 {widget deletion while active} {
+} -cleanup {
destroy .e
+} -result {0}
+
+test entry-20.5 {widget deletion while active} -body {
entry .e -validatecommand { destroy .e ; return 0 }
.e validate
winfo exists .e
-} 0
-test entry-20.6 {widget deletion while active} {
+} -cleanup {
destroy .e
+} -result {0}
+
+test entry-20.6 {widget deletion while active} -body {
pack [entry .e]
update
.e config -xscrollcommand { destroy .e }
update idle
winfo exists .e
-} 0
-test entry-20.7 {widget deletion with textvariable active} {
- # SF bugs 607390 and 617446
+} -cleanup {
destroy .e
+} -result {0}
+
+test entry-20.7 {widget deletion with textvariable active} -body {
+# SF bugs 607390 and 617446
set FOO init
entry .e -textvariable FOO -validate all \
-vcmd {%W configure -bg white; format 1}
bind .e <Destroy> { set FOO hello }
destroy .e
winfo exists .e
-} 0
-
-test entry-21.1 {selection present while disabled, bug 637828} {
+} -cleanup {
destroy .e
+} -result {0}
+
+
+test entry-21.1 {selection present while disabled, bug 637828} -body {
entry .e
.e insert end 0123456789
.e select from 3
.e select to 6
set out [.e selection present]
.e configure -state disabled
- # still return 1 when disabled, because 'selection get' will work,
- # but selection cannot be changed (new behavior since 8.4)
+# still return 1 when disabled, because 'selection get' will work,
+# but selection cannot be changed (new behavior since 8.4)
.e select to 9
lappend out [.e selection present] [selection get]
-} {1 1 345}
-
-test entry-22.1 {lost namespaced textvar} {
+} -cleanup {
destroy .e
+} -result {1 1 345}
+
+test entry-22.1 {lost namespaced textvar} -body {
namespace eval test { variable foo {a b} }
entry .e -textvariable ::test::foo
namespace delete test
.e insert end "more stuff"
.e delete 5 end
- catch {set ::test::foo} result
- list [.e get] [.e cget -textvar] $result
-} [list "a bmo" ::test::foo \
- {can't read "::test::foo": no such variable}]
-
-destroy .e
+ set ::test::foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {can't read "::test::foo": no such variable}
+test entry-22.2 {lost namespaced textvar} -body {
+ namespace eval test { variable foo {a b} }
+ entry .e -textvariable ::test::foo
+ namespace delete test
+ .e insert end "more stuff"
+ .e delete 5 end
+ catch {set ::test::foo}
+ list [.e get] [.e cget -textvar]
+} -cleanup {
+ destroy .e
+} -result [list "a bmo" ::test::foo]
+# Gathered comments about lacks
# XXX Still need to write tests for EntryBlinkProc, EntryFocusProc,
# and EntryTextVarProc.
+# No tests for DisplayEntry.
+# XXX Still need to write tests for EntryScanTo and EntrySelectTo.
+# No tests for EventuallyRedraw
-option clear
-
+# option clear
# cleanup
cleanupTests
return
+
+
+
diff --git a/tests/event.test b/tests/event.test
index fa75610..1548467 100644
--- a/tests/event.test
+++ b/tests/event.test
@@ -6,9 +6,10 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
+namespace import -force tcltest::test
# XXX This test file is woefully incomplete. Right now it only tests
# a few of the procedures in tkEvent.c. Please add more tests whenever
@@ -183,37 +184,49 @@ proc _get_selection {widget} {
# Begining of the actual tests
-test event-1.1 {Tk_HandleEvent procedure, filter events for dead windows} {
+test event-1.1 {Tk_HandleEvent procedure, filter events for dead windows} -setup {
+ deleteWindows
+ set x {}
+} -body {
button .b -text Test
pack .b
bindtags .b .b
update
bind .b <Destroy> {
- lappend x destroy
- event generate .b <1>
- event generate .b <ButtonRelease-1>
+ lappend x destroy
+ event generate .b <1>
+ event generate .b <ButtonRelease-1>
}
bind .b <1> {
- lappend x button
+ lappend x button
}
- set x {}
+
destroy .b
- set x
-} {destroy}
-test event-1.2 {event generate <Alt-z>} {
- catch {destroy .e}
- catch {unset ::event12result}
+ return $x
+} -cleanup {
+ deleteWindows
+} -result {destroy}
+test event-1.2 {event generate <Alt-z>} -setup {
+ deleteWindows
+ catch {unset ::event12result}
+} -body {
set ::event12result 0
pack [entry .e]
update
bind .e <Alt-z> {set ::event12result "1"}
- focus -force .e ; event generate .e <Alt-z>
+
+ focus -force .e
+ event generate .e <Alt-z>
destroy .e
set ::event12result
-} 1
+} -cleanup {
+ deleteWindows
+} -result 1
+
-test event-2.1(keypress) {type into entry widget and hit Return} {
- destroy .t
+test event-2.1(keypress) {type into entry widget and hit Return} -setup {
+ deleteWindows
+} -body {
set t [toplevel .t]
set e [entry $t.e]
pack $e
@@ -222,9 +235,12 @@ test event-2.1(keypress) {type into entry widget and hit Return} {
tkwait visibility $e
_keypress_string $e HELLO\n
list [$e get] $return_binding
-} {HELLO 1}
-test event-2.2(keypress) {type into entry widget and then delete some text} {
- destroy .t
+} -cleanup {
+ deleteWindows
+} -result {HELLO 1}
+test event-2.2(keypress) {type into entry widget and then delete some text} -setup {
+ deleteWindows
+} -body {
set t [toplevel .t]
set e [entry $t.e]
pack $e
@@ -233,10 +249,13 @@ test event-2.2(keypress) {type into entry widget and then delete some text} {
_keypress $e BackSpace
_keypress $e BackSpace
$e get
-} MEL
-test event-2.3(keypress) {type into entry widget, triple click,\
- hit Delete key, and then type some more} {
- destroy .t
+} -cleanup {
+ deleteWindows
+} -result {MEL}
+test event-2.3(keypress) {type into entry widget, triple click, hit Delete key,
+ and then type some more} -setup {
+ deleteWindows
+} -body {
set t [toplevel .t]
set e [entry $t.e]
pack $e
@@ -256,9 +275,12 @@ test event-2.3(keypress) {type into entry widget, triple click,\
_keypress $e Delete
_keypress_string $e UP
lappend result [$e get]
-} {JUMP UP}
-test event-1.4(keypress) {type into text widget and hit Return} {
- destroy .t
+} -cleanup {
+ deleteWindows
+} -result {JUMP UP}
+test event-2.4(keypress) {type into text widget and hit Return} -setup {
+ deleteWindows
+} -body {
set t [toplevel .t]
set e [text $t.e]
pack $e
@@ -267,9 +289,12 @@ test event-1.4(keypress) {type into text widget and hit Return} {
tkwait visibility $e
_keypress_string $e HELLO\n
list [$e get 1.0 end] $return_binding
-} [list "HELLO\n\n" 1]
-test event-2.5(keypress) {type into text widget and then delete some text} {
- destroy .t
+} -cleanup {
+ deleteWindows
+} -result [list "HELLO\n\n" 1]
+test event-2.5(keypress) {type into text widget and then delete some text} -setup {
+ deleteWindows
+} -body {
set t [toplevel .t]
set e [text $t.e]
pack $e
@@ -278,10 +303,13 @@ test event-2.5(keypress) {type into text widget and then delete some text} {
_keypress $e BackSpace
_keypress $e BackSpace
$e get 1.0 1.end
-} MEL
-test event-2.6(keypress) {type into text widget, triple click,\
- hit Delete key, and then type some more} {
- destroy .t
+} -cleanup {
+ deleteWindows
+} -result {MEL}
+test event-2.6(keypress) {type into text widget, triple click,
+ hit Delete key, and then type some more} -setup {
+ deleteWindows
+} -body {
set t [toplevel .t]
set e [text $t.e]
pack $e
@@ -301,11 +329,14 @@ test event-2.6(keypress) {type into text widget, triple click,\
_keypress $e Delete
_keypress_string $e UP
lappend result [$e get 1.0 1.end]
-} {JUMP UP}
-
-test event-3.1(click-drag) {click and drag in a text widget, this tests\
- tkTextSelectTo in text.tcl} {
- destroy .t
+} -cleanup {
+ deleteWindows
+} -result {JUMP UP}
+
+test event-3.1(click-drag) {click and drag in a text widget, this tests
+ tkTextSelectTo in text.tcl} -setup {
+ deleteWindows
+} -body {
set t [toplevel .t]
set e [text $t.e]
pack $e
@@ -366,10 +397,13 @@ test event-3.1(click-drag) {click and drag in a text widget, this tests\
# Save the highlighted text
lappend result [_get_selection $e]
-} {{A Tcl/Tk selection test!} 1.6 1.18 {Tk selection} 1.2 {Tcl/Tk selection}}
-test event-3.2(click-drag) {click and drag in an entry widget, this\
- tests tkEntryMouseSelect in entry.tcl} {
- destroy .t
+} -cleanup {
+ deleteWindows
+} -result {{A Tcl/Tk selection test!} 1.6 1.18 {Tk selection} 1.2 {Tcl/Tk selection}}
+ test event-3.2(click-drag) {click and drag in an entry widget, this
+ tests tkEntryMouseSelect in entry.tcl} -setup {
+ deleteWindows
+} -body {
set t [toplevel .t]
set e [entry $t.e]
pack $e
@@ -430,11 +464,15 @@ test event-3.2(click-drag) {click and drag in an entry widget, this\
# Save the highlighted text
lappend result [_get_selection $e]
-} {{A Tcl/Tk selection!} 6 18 {Tk selection} 2 {Tcl/Tk selection}}
+} -cleanup {
+ deleteWindows
+} -result {{A Tcl/Tk selection!} 6 18 {Tk selection} 2 {Tcl/Tk selection}}
-test event-4.1(double-click-drag) {click down, click up, click down again,\
- then drag in a text widget} {
- destroy .t
+
+test event-4.1(double-click-drag) {click down, click up, click down again,
+ then drag in a text widget} -setup {
+ deleteWindows
+} -body {
set t [toplevel .t]
set e [text $t.e]
pack $e
@@ -497,11 +535,14 @@ test event-4.1(double-click-drag) {click down, click up, click down again,\
# Insert cursor should be before the r in "Word"
lappend result [$e index insert]
- set result
-} {select 1.5 1.7 select 1.4 { select} {Word select} 1.2}
-test event-4.2(double-click-drag) {click down, click up, click down again,\
- then drag in an entry widget} {
- destroy .t
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {select 1.5 1.7 select 1.4 { select} {Word select} 1.2}
+test event-4.2(double-click-drag) {click down, click up, click down again,
+ then drag in an entry widget} -setup {
+ deleteWindows
+} -body {
set t [toplevel .t]
set e [entry $t.e]
pack $e
@@ -564,12 +605,15 @@ test event-4.2(double-click-drag) {click down, click up, click down again,\
# Insert cursor should be before the r in "Word"
lappend result [$e index insert]
- set result
-} {select 11 7 select 4 { select} {Word select} 2}
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {select 11 7 select 4 { select} {Word select} 2}
-test event-5.1(triple-click-drag) {Triple click and drag across lines in\
- a text widget, this should extend the selection to the new line} {
- destroy .t
+test event-5.1(triple-click-drag) {Triple click and drag across lines in a
+ text widget, this should extend the selection to the new line} -setup {
+ deleteWindows
+} -body {
set t [toplevel .t]
set e [text $t.e]
pack $e
@@ -620,16 +664,18 @@ test event-5.1(triple-click-drag) {Triple click and drag across lines in\
lappend result [_get_selection $e]
- set result
-
-} [list "LINE THREE\n" "LINE TWO\nLINE THREE\n" \
+ return $result
+} -cleanup {
+ deleteWindows
+} -result [list "LINE THREE\n" "LINE TWO\nLINE THREE\n" \
"LINE ONE\nLINE TWO\nLINE THREE\n"]
-test event-6.1(button-state) {button press in a window that is then\
- destroyed, when the mouse is moved into another window it\
- should not generate a <B1-motion> event since the mouse\
- was not pressed down in that window} {
- destroy .t
+test event-6.1(button-state) {button press in a window that is then
+ destroyed, when the mouse is moved into another window it
+ should not generate a <B1-motion> event since the mouse
+ was not pressed down in that window} -setup {
+ deleteWindows
+} -body {
set t [toplevel .t]
event generate $t <ButtonPress-1>
@@ -638,12 +684,15 @@ test event-6.1(button-state) {button press in a window that is then\
set motion nomotion
bind $t <B1-Motion> {set motion inmotion}
event generate $t <Motion>
- set motion
-} nomotion
+ return $motion
+} -cleanup {
+ deleteWindows
+} -result {nomotion}
test event-7.1(double-click) {A double click on a lone character
- in a text widget should select that character} {
- destroy .t
+ in a text widget should select that character} -setup {
+ deleteWindows
+} -body {
set t [toplevel .t]
set e [text $t.e]
pack $e
@@ -702,11 +751,16 @@ test event-7.1(double-click) {A double click on a lone character
lappend result [$e index insert]
lappend result [_get_selection $e]
- set result
-} {1.3 A 1.3 A}
-test event-7.2(double-click) {A double click on a lone character\
- in an entry widget should select that character} {knownBug} {
- destroy .t
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {1.3 A 1.3 A}
+test event-7.2(double-click) {A double click on a lone character
+ in an entry widget should select that character} -constraints {
+ knownBug
+} -setup {
+ deleteWindows
+} -body {
set t [toplevel .t]
set e [entry $t.e]
pack $e
@@ -765,13 +819,12 @@ test event-7.2(double-click) {A double click on a lone character\
lappend result [$e index insert]
lappend result [_get_selection $e]
- set result
-} {3 A 4 A}
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {3 A 4 A}
# cleanup
-
-destroy .t
-
unset -nocomplain keypress_lookup
rename _init_keypress_lookup {}
rename _keypress_lookup {}
@@ -782,3 +835,5 @@ rename _get_selection {}
cleanupTests
return
+
+
diff --git a/tests/focus.test b/tests/focus.test
index 5cc3abe..45cf73b 100644
--- a/tests/focus.test
+++ b/tests/focus.test
@@ -6,26 +6,24 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
-
-button .b -text .b -relief raised -bd 2
-pack .b
+namespace import -force tcltest::test
proc focusSetup {} {
- catch {destroy .t}
+ destroy .t
toplevel .t
wm geom .t +0+0
foreach i {b1 b2 b3 b4} {
- button .t.$i -text .t.$i -relief raised -bd 2
- pack .t.$i
+ button .t.$i -text .t.$i -relief raised -bd 2
+ pack .t.$i
}
tkwait visibility .t.b4
}
proc focusSetupAlt {} {
global env
- catch {destroy .alt}
+ destroy .alt
toplevel .alt -screen $env(TK_ALT_DISPLAY)
foreach i {a b c d} {
button .alt.$i -text .alt.$i -relief raised -bd 2
@@ -34,8 +32,6 @@ proc focusSetupAlt {} {
tkwait visibility .alt.d
}
-# Make sure the window manager knows who has focus
-catch {fixfocus}
# The following procedure ensures that there is no input focus
# in this application. It does it by arranging for another
@@ -43,7 +39,6 @@ catch {fixfocus}
# is needed to wait long enough for pending actions to get through
# the X server and possibly also the window manager.
-setupbg
proc focusClear {} {
global x;
after 200 {set x 1}
@@ -52,12 +47,17 @@ proc focusClear {} {
update
}
-focusSetup
-if {[testConstraint altDisplay]} {
- focusSetupAlt
-}
-update
+# Button used in some tests in the whole test file
+button .b -text .b -relief raised -bd 2
+pack .b
+
+# Make sure the window manager knows who has focus
+catch {fixfocus}
+
+# cleanupbg will be after 4.3 test
+setupbg
+update
bind all <FocusIn> {
append focusInfo "in %W %d\n"
}
@@ -67,36 +67,48 @@ bind all <FocusOut> {
bind all <KeyPress> {
append focusInfo "press %W %K"
}
+focusSetup
+if {[testConstraint altDisplay]} {
+ focusSetupAlt
+}
-test focus-1.1 {Tk_FocusCmd procedure} unix {
+
+test focus-1.1 {Tk_FocusCmd procedure} -constraints unix -body {
focusClear
focus
-} {}
-test focus-1.2 {Tk_FocusCmd procedure} {unix altDisplay} {
+} -result {}
+test focus-1.2 {Tk_FocusCmd procedure} -constraints {
+ unix altDisplay
+} -body {
focus .alt.b
focus
-} {}
-test focus-1.3 {Tk_FocusCmd procedure} unix {
+} -result {}
+test focus-1.3 {Tk_FocusCmd procedure} -constraints unix -body {
focusClear
focus .t.b3
focus
-} {}
-test focus-1.4 {Tk_FocusCmd procedure} unix {
- list [catch {focus ""} msg] $msg
-} {0 {}}
-test focus-1.5 {Tk_FocusCmd procedure} unix {
+} -result {}
+test focus-1.4 {Tk_FocusCmd procedure} -constraints unix -body {
+ focus ""
+} -returnCodes ok -result {}
+test focus-1.5 {Tk_FocusCmd procedure} -constraints unix -body {
focusClear
focus -force .t
focus .t.b3
focus
-} {.t.b3}
-test focus-1.6 {Tk_FocusCmd procedure} unix {
- list [catch {focus .gorp} msg] $msg
-} {1 {bad window path name ".gorp"}}
-test focus-1.7 {Tk_FocusCmd procedure} unix {
- list [catch {focus .gorp a} msg] $msg
-} {1 {bad option ".gorp": must be -displayof, -force, or -lastfor}}
-test focus-1.8 {Tk_FocusCmd procedure, focussing on dead window} unix {
+} -result {.t.b3}
+test focus-1.6 {Tk_FocusCmd procedure} -constraints unix -body {
+ focus .gorp
+} -returnCodes error -result {bad window path name ".gorp"}
+test focus-1.7 {Tk_FocusCmd procedure} -constraints unix -body {
+ focus .gorp a
+} -returnCodes error -result {bad option ".gorp": must be -displayof, -force, or -lastfor}
+test focus-1.8 {Tk_FocusCmd procedure, focussing on dead window} -constraints {
+ unix
+} -setup {
+ destroy .t2
+} -body {
+ focusClear
toplevel .t2
wm geom .t2 +10+10
frame .t2.f -width 200 -height 100 -bd 2 -relief raised
@@ -113,109 +125,146 @@ test focus-1.8 {Tk_FocusCmd procedure, focussing on dead window} unix {
destroy .t2.f
lappend x [focus]
destroy .t2
- set x
-} {.t2.f2 .t2 .t2}
-test focus-1.9 {Tk_FocusCmd procedure, -displayof option} unix {
- list [catch {focus -displayof} msg] $msg
-} {1 {wrong # args: should be "focus -displayof window"}}
-test focus-1.10 {Tk_FocusCmd procedure, -displayof option} unix {
- list [catch {focus -displayof a b} msg] $msg
-} {1 {wrong # args: should be "focus -displayof window"}}
-test focus-1.11 {Tk_FocusCmd procedure, -displayof option} unix {
- list [catch {focus -displayof .lousy} msg] $msg
-} {1 {bad window path name ".lousy"}}
-test focus-1.12 {Tk_FocusCmd procedure, -displayof option} unix {
+ return $x
+} -cleanup {
+ destroy .t2
+} -result {.t2.f2 .t2 .t2}
+test focus-1.9 {Tk_FocusCmd procedure, -displayof option} -constraints {
+ unix
+} -body {
+ focus -displayof
+} -returnCodes error -result {wrong # args: should be "focus -displayof window"}
+test focus-1.10 {Tk_FocusCmd procedure, -displayof option} -constraints {
+ unix
+} -body {
+ focus -displayof a b
+} -returnCodes error -result {wrong # args: should be "focus -displayof window"}
+test focus-1.11 {Tk_FocusCmd procedure, -displayof option} -constraints {
+ unix
+} -body {
+ focus -displayof .lousy
+} -returnCodes error -result {bad window path name ".lousy"}
+test focus-1.12 {Tk_FocusCmd procedure, -displayof option} -constraints {
+ unix
+} -body {
focusClear
focus .t
focus -displayof .t.b3
-} {}
-test focus-1.13 {Tk_FocusCmd procedure, -displayof option} unix {
+} -result {}
+test focus-1.13 {Tk_FocusCmd procedure, -displayof option} -constraints {
+ unix
+} -body {
focusClear
focus -force .t
focus -displayof .t.b3
-} {.t}
-test focus-1.14 {Tk_FocusCmd procedure, -displayof option} {unix altDisplay} {
+} -result {.t}
+test focus-1.14 {Tk_FocusCmd procedure, -displayof option} -constraints {
+ unix altDisplay
+} -body {
+ focusClear
focus -force .alt.c
focus -displayof .alt
-} {.alt.c}
-test focus-1.15 {Tk_FocusCmd procedure, -force option} unix {
- list [catch {focus -force} msg] $msg
-} {1 {wrong # args: should be "focus -force window"}}
-test focus-1.16 {Tk_FocusCmd procedure, -force option} unix {
- list [catch {focus -force a b} msg] $msg
-} {1 {wrong # args: should be "focus -force window"}}
-test focus-1.17 {Tk_FocusCmd procedure, -force option} unix {
- list [catch {focus -force foo} msg] $msg
-} {1 {bad window path name "foo"}}
-test focus-1.18 {Tk_FocusCmd procedure, -force option} unix {
- list [catch {focus -force ""} msg] $msg
-} {0 {}}
-test focus-1.19 {Tk_FocusCmd procedure, -force option} unix {
+} -result {.alt.c}
+test focus-1.15 {Tk_FocusCmd procedure, -force option} -constraints unix -body {
+ focus -force
+} -returnCodes error -result {wrong # args: should be "focus -force window"}
+test focus-1.16 {Tk_FocusCmd procedure, -force option} -constraints unix -body {
+ focus -force a b
+} -returnCodes error -result {wrong # args: should be "focus -force window"}
+test focus-1.17 {Tk_FocusCmd procedure, -force option} -constraints unix -body {
+ focus -force foo
+} -returnCodes error -result {bad window path name "foo"}
+test focus-1.18 {Tk_FocusCmd procedure, -force option} -constraints unix -body {
+ focus -force ""
+} -returnCodes ok -result {}
+test focus-1.19 {Tk_FocusCmd procedure, -force option} -constraints unix -body {
focusClear
focus .t.b1
set x [list [focus]]
focus -force .t.b1
lappend x [focus]
-} {{} .t.b1}
-test focus-1.20 {Tk_FocusCmd procedure, -lastfor option} unix {
- list [catch {focus -lastfor} msg] $msg
-} {1 {wrong # args: should be "focus -lastfor window"}}
-test focus-1.21 {Tk_FocusCmd procedure, -lastfor option} unix {
- list [catch {focus -lastfor 1 2} msg] $msg
-} {1 {wrong # args: should be "focus -lastfor window"}}
-test focus-1.22 {Tk_FocusCmd procedure, -lastfor option} unix {
- list [catch {focus -lastfor who_knows?} msg] $msg
-} {1 {bad window path name "who_knows?"}}
-test focus-1.23 {Tk_FocusCmd procedure, -lastfor option} unix {
+} -result {{} .t.b1}
+test focus-1.20 {Tk_FocusCmd procedure, -lastfor option} -constraints {
+ unix
+} -body {
+ focus -lastfor
+} -returnCodes error -result {wrong # args: should be "focus -lastfor window"}
+test focus-1.21 {Tk_FocusCmd procedure, -lastfor option} -constraints {
+ unix
+} -body {
+ focus -lastfor 1 2
+} -returnCodes error -result {wrong # args: should be "focus -lastfor window"}
+test focus-1.22 {Tk_FocusCmd procedure, -lastfor option} -constraints {
+ unix
+} -body {
+ focus -lastfor who_knows?
+} -returnCodes error -result {bad window path name "who_knows?"}
+test focus-1.23 {Tk_FocusCmd procedure, -lastfor option} -constraints {
+ unix
+} -body {
+ focusClear
+ focusSetup
focus .b
focus .t.b1
list [focus -lastfor .] [focus -lastfor .t.b3]
-} {.b .t.b1}
-test focus-1.24 {Tk_FocusCmd procedure, -lastfor option} unix {
- destroy .t
+} -result {.b .t.b1}
+test focus-1.24 {Tk_FocusCmd procedure, -lastfor option} -constraints {
+ unix
+} -body {
+ focusClear
focusSetup
update
focus -lastfor .t.b2
-} {.t}
-test focus-1.25 {Tk_FocusCmd procedure} unix {
- list [catch {focus -unknown} msg] $msg
-} {1 {bad option "-unknown": must be -displayof, -force, or -lastfor}}
+} -result {.t}
+test focus-1.25 {Tk_FocusCmd procedure} -constraints unix -body {
+ focus -unknown
+} -returnCodes error -result {bad option "-unknown": must be -displayof, -force, or -lastfor}
+
-test focus-2.1 {TkFocusFilterEvent procedure} {unix nonPortable testwrapper} {
+focusSetup
+test focus-2.1 {TkFocusFilterEvent procedure} -constraints {
+ unix nonPortable testwrapper
+} -body {
+ focusClear
focus -force .b
- destroy .t
focusSetup
update
set focusInfo {}
event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor \
-sendevent 0x54217567
- list $focusInfo
-} {{}}
-test focus-2.2 {TkFocusFilterEvent procedure} {unix nonPortable testwrapper} {
+ return $focusInfo
+} -result {}
+test focus-2.2 {TkFocusFilterEvent procedure} -constraints {
+ unix nonPortable testwrapper
+} -body {
+ focusClear
focus -force .b
- destroy .t
focusSetup
update
set focusInfo {}
event gen .t <FocusIn> -detail NotifyAncestor -sendevent 0x547321ac
list $focusInfo [focus]
-} {{in .t NotifyAncestor
+} -result {{in .t NotifyAncestor
} .b}
-test focus-2.3 {TkFocusFilterEvent procedure} {unix nonPortable testwrapper} {
+test focus-2.3 {TkFocusFilterEvent procedure} -constraints {
+ unix nonPortable testwrapper
+} -body {
+ focusClear
focus -force .b
- destroy .t
focusSetup
update
set focusInfo {}
event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor
update
list $focusInfo [focus -lastfor .t]
-} {{out .b NotifyNonlinear
+} -result {{out .b NotifyNonlinear
out . NotifyNonlinearVirtual
in .t NotifyNonlinear
} .t}
-test focus-2.4 {TkFocusFilterEvent procedure, FocusIn events} \
- {unix nonPortable testwrapper} {
+test focus-2.4 {TkFocusFilterEvent procedure, FocusIn events} -constraints {
+ unix nonPortable testwrapper
+} -body {
+ focusClear
set result {}
focus .t.b1
# Important to end with NotifyAncestor, which is an
@@ -231,8 +280,8 @@ test focus-2.4 {TkFocusFilterEvent procedure, FocusIn events} \
update
lappend result $focusInfo
}
- set result
-} {{out . NotifyNonlinear
+ return $result
+} -result {{out . NotifyNonlinear
in .t NotifyNonlinearVirtual
in .t.b1 NotifyNonlinear
} {out . NotifyNonlinear
@@ -245,19 +294,22 @@ in .t.b1 NotifyNonlinear
in .t NotifyNonlinearVirtual
in .t.b1 NotifyNonlinear
}}
-test focus-2.5 {TkFocusFilterEvent procedure, creating FocusInfo struct} \
- {unix nonPortable testwrapper} {
+test focus-2.5 {TkFocusFilterEvent procedure, creating FocusInfo struct} -constraints {
+ unix nonPortable testwrapper
+} -body {
focusSetup
focus .t.b1
update
event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor
list $focusInfo [focus]
-} {{out . NotifyNonlinear
+} -result {{out . NotifyNonlinear
in .t NotifyNonlinearVirtual
in .t.b1 NotifyNonlinear
} .t.b1}
-test focus-2.6 {TkFocusFilterEvent procedure, FocusIn events} \
- {unix testwrapper} {
+
+test focus-2.6 {TkFocusFilterEvent procedure, FocusIn events} -constraints {
+ unix testwrapper
+} -body {
focus .t.b1
focus .
update
@@ -266,117 +318,131 @@ test focus-2.6 {TkFocusFilterEvent procedure, FocusIn events} \
set x [focus]
event gen . <KeyPress-x>
list $x $focusInfo
-} {.t.b1 {press .t.b1 x}}
-test focus-2.7 {TkFocusFilterEvent procedure, FocusOut events} \
- {unix testwrapper} {
+} -result {.t.b1 {press .t.b1 x}}
+test focus-2.7 {TkFocusFilterEvent procedure, FocusOut events} -constraints {
+ unix testwrapper
+} -body {
set result {}
foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear
NotifyNonlinearVirtual NotifyPointer NotifyPointerRoot
NotifyVirtual} {
- focus -force .t.b1
- event gen [testwrapper .t] <FocusOut> -detail $detail
- update
- lappend result [focus]
+ focus -force .t.b1
+ event gen [testwrapper .t] <FocusOut> -detail $detail
+ update
+ lappend result [focus]
}
- set result
-} {{} .t.b1 {} {} .t.b1 .t.b1 {}}
-test focus-2.8 {TkFocusFilterEvent procedure, FocusOut events} \
- {unix testwrapper} {
+ return $result
+} -result {{} .t.b1 {} {} .t.b1 .t.b1 {}}
+test focus-2.8 {TkFocusFilterEvent procedure, FocusOut events} -constraints {
+ unix testwrapper
+} -body {
focus -force .t.b1
event gen .t.b1 <FocusOut> -detail NotifyAncestor
focus
-} {.t.b1}
-test focus-2.9 {TkFocusFilterEvent procedure, FocusOut events} \
- {unix testwrapper} {
+} -result {.t.b1}
+test focus-2.9 {TkFocusFilterEvent procedure, FocusOut events} -constraints {
+ unix testwrapper
+} -body {
focus .t.b1
event gen [testwrapper .] <FocusOut> -detail NotifyAncestor
focus
-} {}
-test focus-2.10 {TkFocusFilterEvent procedure, Enter events} \
- {unix testwrapper} {
+} -result {}
+test focus-2.10 {TkFocusFilterEvent procedure, Enter events} -constraints {
+ unix testwrapper
+} -body {
set result {}
focus .t.b1
focusClear
foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear
- NotifyNonlinearVirtual NotifyVirtual} {
- event gen [testwrapper .t] <Enter> -detail $detail -focus 1
- update
- lappend result [focus]
- event gen [testwrapper .t] <Leave> -detail NotifyAncestor
- update
+ NotifyNonlinearVirtual NotifyVirtual} {
+ event gen [testwrapper .t] <Enter> -detail $detail -focus 1
+ update
+ lappend result [focus]
+ event gen [testwrapper .t] <Leave> -detail NotifyAncestor
+ update
}
- set result
-} {.t.b1 {} .t.b1 .t.b1 .t.b1}
-test focus-2.11 {TkFocusFilterEvent procedure, Enter events} \
- {unix testwrapper} {
+ return $result
+} -result {.t.b1 {} .t.b1 .t.b1 .t.b1}
+test focus-2.11 {TkFocusFilterEvent procedure, Enter events} -constraints {
+ unix testwrapper
+} -body {
focusClear
set focusInfo {}
event gen [testwrapper .t] <Enter> -detail NotifyAncestor
update
- set focusInfo
-} {}
-test focus-2.12 {TkFocusFilterEvent procedure, Enter events} \
- {unix testwrapper} {
+ return $focusInfo
+} -result {}
+test focus-2.12 {TkFocusFilterEvent procedure, Enter events} -constraints {
+ unix testwrapper
+} -body {
focus -force .b
update
set focusInfo {}
event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1
update
- set focusInfo
-} {}
-test focus-2.13 {TkFocusFilterEvent procedure, Enter events} \
- {unix testwrapper} {
+ return $focusInfo
+} -result {}
+test focus-2.13 {TkFocusFilterEvent procedure, Enter events} -constraints {
+ unix testwrapper
+} -body {
focus .t.b1
focusClear
event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1
set focusInfo {}
update
- set focusInfo
-} {in .t NotifyVirtual
+ return $focusInfo
+} -result {in .t NotifyVirtual
in .t.b1 NotifyAncestor
}
-test focus-2.14 {TkFocusFilterEvent procedure, Enter events, ignore errors when setting focus due to implicit focus} {unix testwrapper} {
+test focus-2.14 {TkFocusFilterEvent procedure, Enter events, ignore errors when setting focus due to implicit focus} -constraints {
+ unix testwrapper
+} -setup {
+ destroy .t2
+ set focusInfo {}
+} -body {
focusClear
- catch {destroy .t2}
toplevel .t2
wm withdraw .t2
update
- set focusInfo {}
event gen [testwrapper .t2] <Enter> -detail NotifyAncestor -focus 1
update
+} -cleanup {
destroy .t2
-} {}
-test focus-2.15 {TkFocusFilterEvent procedure, Leave events} \
- {unix testwrapper} {
+} -result {}
+test focus-2.15 {TkFocusFilterEvent procedure, Leave events} -constraints {
+ unix testwrapper
+} -body {
set result {}
focus .t.b1
foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear
NotifyNonlinearVirtual NotifyVirtual} {
- focusClear
- event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1
- update
- event gen [testwrapper .t] <Leave> -detail $detail
- update
- lappend result [focus]
+ focusClear
+ event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1
+ update
+ event gen [testwrapper .t] <Leave> -detail $detail
+ update
+ lappend result [focus]
}
- set result
-} {{} .t.b1 {} {} {}}
-test focus-2.16 {TkFocusFilterEvent procedure, Leave events} \
- {unix testwrapper} {
- set result {}
+ return $result
+} -result {{} .t.b1 {} {} {}}
+test focus-2.16 {TkFocusFilterEvent procedure, Leave events} -constraints {
+ unix testwrapper
+} -body {
+ focusClear
focus .t.b1
event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1
update
set focusInfo {}
event gen [testwrapper .t] <Leave> -detail NotifyAncestor
update
- set focusInfo
-} {out .t.b1 NotifyAncestor
+ return $focusInfo
+} -result {out .t.b1 NotifyAncestor
out .t NotifyVirtual
}
-test focus-2.17 {TkFocusFilterEvent procedure, Leave events} \
- {unix testwrapper} {
- set result {}
+test focus-2.17 {TkFocusFilterEvent procedure, Leave events} -constraints {
+ unix testwrapper
+} -body {
+ focusClear
focus .t.b1
event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1
update
@@ -385,41 +451,49 @@ test focus-2.17 {TkFocusFilterEvent procedure, Leave events} \
event gen [testwrapper .] <Leave> -detail NotifyAncestor
update
list $focusInfo [focus]
-} {{out .t.b1 NotifyAncestor
+} -result {{out .t.b1 NotifyAncestor
out .t NotifyVirtual
} {}}
-test focus-3.1 {SetFocus procedure, create record on focus} \
- {unix testwrapper} {
+
+test focus-3.1 {SetFocus procedure, create record on focus} -constraints {
+ unix testwrapper
+} -body {
toplevel .t2 -width 250 -height 100
wm geometry .t2 +0+0
update
focus -force .t2
update
focus
-} {.t2}
-catch {destroy .t2}
+} -cleanup {
+ destroy .t2
+} -result {.t2}
# This test produces no result, but it will generate a protocol
# error if Tk forgets to make the window exist before focussing
# on it.
-test focus-3.2 {SetFocus procedure, making window exist} {unix testwrapper} {
+test focus-3.2 {SetFocus procedure, making window exist} -constraints {
+ unix testwrapper
+} -body {
update
button .b2 -text "Another button"
focus .b2
update
-} {}
-catch {destroy .b2}
-update
+} -cleanup {
+ destroy .b2
+ update
+} -result {}
# The following test doesn't produce a check-able result, but if
# there are bugs it may generate an X protocol error.
-test focus-3.3 {SetFocus procedure, delaying claim of X focus} \
- {unix testwrapper} {
+test focus-3.3 {SetFocus procedure, delaying claim of X focus} -constraints {
+ unix testwrapper
+} -body {
focusSetup
focus -force .t.b2
update
-} {}
-test focus-3.4 {SetFocus procedure, delaying claim of X focus} \
- {unix testwrapper} {
+} -result {}
+test focus-3.4 {SetFocus procedure, delaying claim of X focus} -constraints {
+ unix testwrapper
+} -body {
focusSetup
wm withdraw .t
focus -force .t.b2
@@ -430,52 +504,62 @@ test focus-3.4 {SetFocus procedure, delaying claim of X focus} \
update
wm deiconify .t2
wm deiconify .t
-} {}
-catch {destroy .t2}
-test focus-3.5 {SetFocus procedure, generating events} {unix testwrapper} {
+} -cleanup {
+ destroy .t2
+} -result {}
+test focus-3.5 {SetFocus procedure, generating events} -constraints {
+ unix testwrapper
+} -body {
focusSetup
focusClear
set focusInfo {}
focus -force .t.b2
update
- set focusInfo
-} {in .t NotifyVirtual
+ return $focusInfo
+} -result {in .t NotifyVirtual
in .t.b2 NotifyAncestor
}
-test focus-3.6 {SetFocus procedure, generating events} {unix testwrapper} {
+test focus-3.6 {SetFocus procedure, generating events} -constraints {
+ unix testwrapper
+} -body {
focusSetup
focus -force .b
update
set focusInfo {}
focus .t.b2
update
- set focusInfo
-} {out .b NotifyNonlinear
+ return $focusInfo
+} -result {out .b NotifyNonlinear
out . NotifyNonlinearVirtual
in .t NotifyNonlinearVirtual
in .t.b2 NotifyNonlinear
}
-test focus-3.7 {SetFocus procedure, generating events} \
- {unix nonPortable testwrapper} {
+test focus-3.7 {SetFocus procedure, generating events} -constraints {
+unix nonPortable testwrapper
+} -body {
# Non-portable because some platforms generate extra events.
-
focusSetup
focusClear
set focusInfo {}
focus .t.b2
update
- set focusInfo
-} {}
+ return $focusInfo
+} -result {}
+
-test focus-4.1 {TkFocusDeadWindow procedure} {unix testwrapper} {
+test focus-4.1 {TkFocusDeadWindow procedure} -constraints {
+ unix testwrapper
+} -body {
focusSetup
update
focus -force .b
update
destroy .t
focus
-} {.b}
-test focus-4.2 {TkFocusDeadWindow procedure} {unix testwrapper} {
+} -result {.b}
+test focus-4.2 {TkFocusDeadWindow procedure} -constraints {
+ unix testwrapper
+} -body {
focusSetup
update
focus -force .t.b2
@@ -484,12 +568,12 @@ test focus-4.2 {TkFocusDeadWindow procedure} {unix testwrapper} {
destroy .t.b2
update
focus
-} {.b}
-
+} -result {.b}
# Non-portable due to wm-specific redirection of input focus when
# windows are deleted:
-
-test focus-4.3 {TkFocusDeadWindow procedure} {unix nonPortable testwrapper} {
+test focus-4.3 {TkFocusDeadWindow procedure} -constraints {
+ unix nonPortable testwrapper
+} -body {
focusSetup
update
focus .t
@@ -497,21 +581,27 @@ test focus-4.3 {TkFocusDeadWindow procedure} {unix nonPortable testwrapper} {
destroy .t
update
focus
-} {}
-test focus-4.4 {TkFocusDeadWindow procedure} {unix testwrapper} {
+} -result {}
+test focus-4.4 {TkFocusDeadWindow procedure} -constraints {
+ unix testwrapper
+} -body {
focusSetup
focus -force .t.b2
update
destroy .t.b2
focus
-} {.t}
+} -result {.t}
+cleanupbg
+
# I don't know how to test most of the remaining procedures of this file
# explicitly; they've already been exercised by the preceding tests.
-setupbg
-test focus-5.1 {ChangeXFocus procedure, don't take focus unless have it} \
- {unix testwrapper secureserver} {
+# Test 5.1 fails (before and after update)
+test focus-5.1 {ChangeXFocus procedure, don't take focus unless have it} -constraints {
+ unix testwrapper secureserver
+} -body {
+ setupbg
focusSetup
focus -force .t
update
@@ -521,19 +611,21 @@ test focus-5.1 {ChangeXFocus procedure, don't take focus unless have it} \
focus .t.b2
update
lappend result [focus]
-} {.t {} {}}
-
-catch {destroy .t}
+} -cleanup {
+ cleanupbg
+} -result {.t {} {}}
+destroy .t
bind all <FocusIn> {}
bind all <FocusOut> {}
bind all <KeyPress> {}
-cleanupbg
-fixfocus
-test focus-6.1 {miscellaneous - embedded application in same process} \
- {unix testwrapper} {
+
+fixfocus
+test focus-6.1 {miscellaneous - embedded application in same process} -constraints {
+ unix testwrapper
+} -setup {
eval interp delete [interp slaves]
- catch {destroy .t}
+} -body {
toplevel .t
wm geometry .t +0+0
frame .t.f1 -container 1
@@ -547,11 +639,11 @@ test focus-6.1 {miscellaneous - embedded application in same process} \
child eval "set argv {-use [winfo id .t.f1]}"
load {} Tk child
child eval {
- entry .e1 -bg lightBlue
- pack .e1
- bind all <FocusIn> {lappend x "focus in %W %d"}
- bind all <FocusOut> {lappend x "focus out %W %d"}
- set x {}
+ entry .e1 -bg lightBlue
+ pack .e1
+ bind all <FocusIn> {lappend x "focus in %W %d"}
+ bind all <FocusOut> {lappend x "focus out %W %d"}
+ set x {}
}
# Claim the focus and wait long enough for it to really arrive.
@@ -577,13 +669,17 @@ test focus-6.1 {miscellaneous - embedded application in same process} \
after 300 {set timer 1}
vwait timer
set result [list $x [child eval {set x}]]
+ return $result
+} -cleanup {
interp delete child
- set result
-} {{.t.f2.e1 {} {focus out .t.f2.e1 NotifyNonlinear} {focus out .t.f2 NotifyNonlinearVirtual} {focus in .t.f1 NotifyNonlinear} | {focus out .t.f1 NotifyNonlinear} {focus in .t.f2 NotifyNonlinearVirtual} {focus in .t.f2.e1 NotifyNonlinear}} {{focus in . NotifyVirtual} {focus in .e1 NotifyAncestor} | {focus out .e1 NotifyAncestor} {focus out . NotifyVirtual}}}
-test focus-6.2 {miscellaneous - embedded application in different process} \
- {unix testwrapper} {
- eval interp delete [interp slaves]
- catch {destroy .t}
+ destroy .t
+ bind all <FocusIn> {}
+ bind all <FocusOut> {}
+} -result {{.t.f2.e1 {} {focus out .t.f2.e1 NotifyNonlinear} {focus out .t.f2 NotifyNonlinearVirtual} {focus in .t.f1 NotifyNonlinear} | {focus out .t.f1 NotifyNonlinear} {focus in .t.f2 NotifyNonlinearVirtual} {focus in .t.f2.e1 NotifyNonlinear}} {{focus in . NotifyVirtual} {focus in .e1 NotifyAncestor} | {focus out .e1 NotifyAncestor} {focus out . NotifyVirtual}}}
+
+test focus-6.2 {miscellaneous - embedded application in different process} -constraints {
+ unix testwrapper
+} -body {
setupbg
toplevel .t
wm geometry .t +0+0
@@ -596,11 +692,11 @@ test focus-6.2 {miscellaneous - embedded application in different process} \
bind all <FocusOut> {lappend x "focus out %W %d"}
setupbg -use [winfo id .t.f1]
dobg {
- entry .e1 -bg lightBlue
- pack .e1
- bind all <FocusIn> {lappend x "focus in %W %d"}
- bind all <FocusOut> {lappend x "focus out %W %d"}
- set x {}
+ entry .e1 -bg lightBlue
+ pack .e1
+ bind all <FocusIn> {lappend x "focus in %W %d"}
+ bind all <FocusOut> {lappend x "focus out %W %d"}
+ set x {}
}
# Claim the focus and wait long enough for it to really arrive.
@@ -626,13 +722,17 @@ test focus-6.2 {miscellaneous - embedded application in different process} \
after 300 {set timer 1}
vwait timer
set result [list $x [dobg {set x}]]
+ return $result
+} -cleanup {
+ destroy .t
cleanupbg
- set result
-} {{.t.f2.e1 {} {focus out .t.f2.e1 NotifyNonlinear} {focus out .t.f2 NotifyNonlinearVirtual} {focus in .t.f1 NotifyNonlinear} | {focus out .t.f1 NotifyNonlinear} {focus in .t.f2 NotifyNonlinearVirtual} {focus in .t.f2.e1 NotifyNonlinear}} {{focus in . NotifyVirtual} {focus in .e1 NotifyAncestor} | {focus out .e1 NotifyAncestor} {focus out . NotifyVirtual}}}
+ bind all <FocusIn> {}
+ bind all <FocusOut> {}
+} -result {{.t.f2.e1 {} {focus out .t.f2.e1 NotifyNonlinear} {focus out .t.f2 NotifyNonlinearVirtual} {focus in .t.f1 NotifyNonlinear} | {focus out .t.f1 NotifyNonlinear} {focus in .t.f2 NotifyNonlinearVirtual} {focus in .t.f2.e1 NotifyNonlinear}} {{focus in . NotifyVirtual} {focus in .e1 NotifyAncestor} | {focus out .e1 NotifyAncestor} {focus out . NotifyVirtual}}}
+
+
deleteWindows
-bind all <FocusIn> {}
-bind all <FocusOut> {}
# cleanup
cleanupTests
diff --git a/tests/focusTcl.test b/tests/focusTcl.test
index 1f5eed5..ef848bb 100644
--- a/tests/focusTcl.test
+++ b/tests/focusTcl.test
@@ -7,131 +7,262 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+option add *takeFocus 1
+option add *highlightThickness 2
+. configure -takefocus 1 -highlightthickness 2
proc setup1 w {
if {$w == "."} {
- set w ""
+ set w ""
}
foreach i {a b c d} {
- frame $w.$i -width 200 -height 50 -bd 2 -relief raised
- pack $w.$i
+ destroy $w.$i
+ frame $w.$i -width 200 -height 50 -bd 2 -relief raised
+ pack $w.$i
}
.b configure -width 0 -height 0
foreach i {x y z} {
- button $w.b.$i -text "Button $w.b.$i"
- pack $w.b.$i -side left
+ destroy $w.b.$i
+ button $w.b.$i -text "Button $w.b.$i"
+ pack $w.b.$i -side left
}
if {![winfo ismapped $w.b.z]} {
- tkwait visibility $w.b.z
+ tkwait visibility $w.b.z
}
}
-option add *takeFocus 1
-option add *highlightThickness 2
-. configure -takefocus 1 -highlightthickness 2
-test focusTcl-1.1 {tk_focusNext procedure, no children} {
+proc cleanup1 w {
+ if {$w == "."} {
+ set w ""
+ }
+ foreach i {a b c d} {
+ destroy $w.$i
+ }
+ foreach i {x y z} {
+ destroy $w.b.$i
+ }
+}
+
+
+test focusTcl-1.1 {tk_focusNext procedure, no children} -body {
tk_focusNext .
-} {.}
-setup1 .
-test focusTcl-1.2 {tk_focusNext procedure, basic tree traversal} {
+} -result {.}
+
+test focusTcl-1.2 {tk_focusNext procedure, basic tree traversal} -body {
+ setup1 .
tk_focusNext .
-} {.a}
-test focusTcl-1.3 {tk_focusNext procedure, basic tree traversal} {
+} -cleanup {
+ cleanup1 .
+} -result {.a}
+test focusTcl-1.3 {tk_focusNext procedure, basic tree traversal} -body {
+ setup1 .
tk_focusNext .a
-} {.b}
-test focusTcl-1.4 {tk_focusNext procedure, basic tree traversal} {
+} -cleanup {
+ cleanup1 .
+} -result {.b}
+test focusTcl-1.4 {tk_focusNext procedure, basic tree traversal} -body {
+ setup1 .
tk_focusNext .b
-} {.b.x}
-test focusTcl-1.5 {tk_focusNext procedure, basic tree traversal} {
+} -cleanup {
+ cleanup1 .
+} -result {.b.x}
+test focusTcl-1.5 {tk_focusNext procedure, basic tree traversal} -body {
+ setup1 .
tk_focusNext .b.x
-} {.b.y}
-test focusTcl-1.6 {tk_focusNext procedure, basic tree traversal} {
+} -cleanup {
+ cleanup1 .
+} -result {.b.y}
+test focusTcl-1.6 {tk_focusNext procedure, basic tree traversal} -body {
+ setup1 .
tk_focusNext .b.y
-} {.b.z}
-test focusTcl-1.7 {tk_focusNext procedure, basic tree traversal} {
+} -cleanup {
+ cleanup1 .
+} -result {.b.z}
+test focusTcl-1.7 {tk_focusNext procedure, basic tree traversal} -body {
+ setup1 .
tk_focusNext .b.z
-} {.c}
-test focusTcl-1.8 {tk_focusNext procedure, basic tree traversal} {
+} -cleanup {
+ cleanup1 .
+} -result {.c}
+test focusTcl-1.8 {tk_focusNext procedure, basic tree traversal} -body {
+ setup1 .
tk_focusNext .c
-} {.d}
-test focusTcl-1.9 {tk_focusNext procedure, basic tree traversal} {
+} -cleanup {
+ cleanup1 .
+} -result {.d}
+test focusTcl-1.9 {tk_focusNext procedure, basic tree traversal} -body {
+ setup1 .
tk_focusNext .d
-} {.}
-foreach w {.b .b.x .b.y .c .d} {
- $w configure -takefocus 0
-}
-test focusTcl-1.10 {tk_focusNext procedure, basic tree traversal} {
+} -cleanup {
+ cleanup1 .
+} -result {.}
+
+test focusTcl-1.10 {tk_focusNext procedure, basic tree traversal} -body {
+ setup1 .
+ foreach w {.b .b.x .b.y .c .d} {
+ $w configure -takefocus 0
+ }
tk_focusNext .a
-} {.b.z}
-test focusTcl-1.11 {tk_focusNext procedure, basic tree traversal} {
+} -cleanup {
+ cleanup1 .
+} -result {.b.z}
+test focusTcl-1.11 {tk_focusNext procedure, basic tree traversal} -body {
+ setup1 .
+ foreach w {.b .b.x .b.y .c .d} {
+ $w configure -takefocus 0
+ }
tk_focusNext .b.z
-} {.}
-test focusTcl-1.12 {tk_focusNext procedure, basic tree traversal} {
+} -cleanup {
+ cleanup1 .
+} -result {.}
+
+test focusTcl-1.12 {tk_focusNext procedure, basic tree traversal} -body {
+ setup1 .
deleteWindows
setup1 .
update
. configure -takefocus 0
tk_focusNext .d
-} {.a}
-. configure -takefocus 1
+} -cleanup {
+ . configure -takefocus 1
+ cleanup1 .
+} -result {.a}
+
+
+test focusTcl-2.1 {tk_focusNext procedure, toplevels} -setup {
+ deleteWindows
+} -body {
+ setup1 .
+ toplevel .t
+ wm geom .t +0+0
+ toplevel .t2
+ wm geom .t2 -0+0
+ raise .t .a
-deleteWindows
-setup1 .
-toplevel .t
-wm geom .t +0+0
-toplevel .t2
-wm geom .t2 -0+0
-raise .t .a
-test focusTcl-2.1 {tk_focusNext procedure, toplevels} {
tk_focusNext .a
-} {.b}
-test focusTcl-2.2 {tk_focusNext procedure, toplevels} {
+} -cleanup {
+ deleteWindows
+} -result {.b}
+test focusTcl-2.2 {tk_focusNext procedure, toplevels} -setup {
+ deleteWindows
+} -body {
+ setup1 .
+ toplevel .t
+ wm geom .t +0+0
+ toplevel .t2
+ wm geom .t2 -0+0
+ raise .t .a
+
tk_focusNext .d
-} {.}
-test focusTcl-2.3 {tk_focusNext procedure, toplevels} {
+} -cleanup {
+ deleteWindows
+} -result {.}
+test focusTcl-2.3 {tk_focusNext procedure, toplevels} -setup {
+ deleteWindows
+} -body {
+ setup1 .
+ toplevel .t
+ wm geom .t +0+0
+ toplevel .t2
+ wm geom .t2 -0+0
+ raise .t .a
+
tk_focusNext .t
-} {.t}
-setup1 .t
-raise .t.b
-test focusTcl-2.4 {tk_focusNext procedure, toplevels} {
+} -cleanup {
+ deleteWindows
+} -result {.t}
+test focusTcl-2.4 {tk_focusNext procedure, toplevels} -setup {
+ deleteWindows
+} -body {
+ setup1 .
+ toplevel .t
+ wm geom .t +0+0
+ toplevel .t2
+ wm geom .t2 -0+0
+ raise .t .a
+ setup1 .t
+ raise .t.b
+
tk_focusNext .t
-} {.t.a}
-test focusTcl-2.5 {tk_focusNext procedure, toplevels} {
+} -cleanup {
+ deleteWindows
+} -result {.t.a}
+test focusTcl-2.5 {tk_focusNext procedure, toplevels} -setup {
+ deleteWindows
+} -body {
+ setup1 .
+ toplevel .t
+ wm geom .t +0+0
+ toplevel .t2
+ wm geom .t2 -0+0
+ raise .t .a
+ setup1 .t
+ raise .t.b
+
tk_focusNext .t.b.z
-} {.t}
+} -cleanup {
+ deleteWindows
+} -result {.t}
-deleteWindows
-test focusTcl-3.1 {tk_focusPrev procedure, no children} {
+
+test focusTcl-3.1 {tk_focusPrev procedure, no children} -body {
tk_focusPrev .
-} {.}
-setup1 .
-test focusTcl-3.2 {tk_focusPrev procedure, basic tree traversal} {
+} -result {.}
+
+test focusTcl-3.2 {tk_focusPrev procedure, basic tree traversal} -body {
+ setup1 .
tk_focusPrev .
-} {.d}
-test focusTcl-3.3 {tk_focusPrev procedure, basic tree traversal} {
+} -cleanup {
+ cleanup1 .
+} -result {.d}
+test focusTcl-3.3 {tk_focusPrev procedure, basic tree traversal} -body {
+ setup1 .
tk_focusPrev .d
-} {.c}
-test focusTcl-3.4 {tk_focusPrev procedure, basic tree traversal} {
+} -cleanup {
+ cleanup1 .
+} -result {.c}
+test focusTcl-3.4 {tk_focusPrev procedure, basic tree traversal} -body {
+ setup1 .
tk_focusPrev .c
-} {.b.z}
-test focusTcl-3.5 {tk_focusPrev procedure, basic tree traversal} {
+} -cleanup {
+ cleanup1 .
+} -result {.b.z}
+test focusTcl-3.5 {tk_focusPrev procedure, basic tree traversal} -body {
+ setup1 .
tk_focusPrev .b.z
-} {.b.y}
-test focusTcl-3.6 {tk_focusPrev procedure, basic tree traversal} {
+} -cleanup {
+ cleanup1 .
+} -result {.b.y}
+test focusTcl-3.6 {tk_focusPrev procedure, basic tree traversal} -body {
+ setup1 .
tk_focusPrev .b.y
-} {.b.x}
-test focusTcl-3.7 {tk_focusPrev procedure, basic tree traversal} {
+} -cleanup {
+ cleanup1 .
+} -result {.b.x}
+test focusTcl-3.7 {tk_focusPrev procedure, basic tree traversal} -body {
+ setup1 .
tk_focusPrev .b.x
-} {.b}
-test focusTcl-3.8 {tk_focusPrev procedure, basic tree traversal} {
+} -cleanup {
+ cleanup1 .
+} -result {.b}
+test focusTcl-3.8 {tk_focusPrev procedure, basic tree traversal} -body {
+ setup1 .
tk_focusPrev .b
-} {.a}
-test focusTcl-3.9 {tk_focusPrev procedure, basic tree traversal} {
+} -cleanup {
+ cleanup1 .
+} -result {.a}
+test focusTcl-3.9 {tk_focusPrev procedure, basic tree traversal} -body {
+ setup1 .
tk_focusPrev .a
-} {.}
+} -cleanup {
+ cleanup1 .
+} -result {.}
+
deleteWindows
setup1 .
@@ -140,35 +271,95 @@ wm geom .t +0+0
toplevel .t2
wm geom .t2 -0+0
raise .t .a
-test focusTcl-4.1 {tk_focusPrev procedure, toplevels} {
+test focusTcl-4.1 {tk_focusPrev procedure, toplevels} -setup {
+ deleteWindows
+} -body {
+ setup1 .
+ toplevel .t
+ wm geom .t +0+0
+ toplevel .t2
+ wm geom .t2 -0+0
+ raise .t .a
+
tk_focusPrev .
-} {.d}
-test focusTcl-4.2 {tk_focusPrev procedure, toplevels} {
+} -cleanup {
+ deleteWindows
+} -result {.d}
+test focusTcl-4.2 {tk_focusPrev procedure, toplevels} -setup {
+ deleteWindows
+} -body {
+ setup1 .
+ toplevel .t
+ wm geom .t +0+0
+ toplevel .t2
+ wm geom .t2 -0+0
+ raise .t .a
+
tk_focusPrev .b
-} {.a}
-test focusTcl-4.3 {tk_focusPrev procedure, toplevels} {
+} -cleanup {
+ deleteWindows
+} -result {.a}
+test focusTcl-4.3 {tk_focusPrev procedure, toplevels} -setup {
+ deleteWindows
+} -body {
+ setup1 .
+ toplevel .t
+ wm geom .t +0+0
+ toplevel .t2
+ wm geom .t2 -0+0
+ raise .t .a
+
tk_focusPrev .t
-} {.t}
-setup1 .t
-update
-.t configure -takefocus 0
-raise .t.b
-test focusTcl-4.4 {tk_focusPrev procedure, toplevels} {
+} -cleanup {
+ deleteWindows
+} -result {.t}
+
+test focusTcl-4.4 {tk_focusPrev procedure, toplevels} -setup {
+ deleteWindows
+} -body {
+ setup1 .
+ toplevel .t
+ wm geom .t +0+0
+ toplevel .t2
+ wm geom .t2 -0+0
+ raise .t .a
+ setup1 .t
+ update
+ .t configure -takefocus 0
+ raise .t.b
+
tk_focusPrev .t
-} {.t.b.z}
-test focusTcl-4.5 {tk_focusPrev procedure, toplevels} {
- tk_focusPrev .t.a
-} {.t.b.z}
+} -cleanup {
+ deleteWindows
+} -result {.t.b.z}
+test focusTcl-4.5 {tk_focusPrev procedure, toplevels} -setup {
+ deleteWindows
+} -body {
+ setup1 .
+ toplevel .t
+ wm geom .t +0+0
+ toplevel .t2
+ wm geom .t2 -0+0
+ raise .t .a
+ setup1 .t
+ update
+ .t configure -takefocus 0
+ raise .t.b
-deleteWindows
-test focusTcl-5.1 {tkFocusOK procedure, -takefocus 0} {
+ tk_focusPrev .t.a
+} -cleanup {
deleteWindows
+} -result {.t.b.z}
+
+
+test focusTcl-5.1 {tkFocusOK procedure, -takefocus 0} -body {
setup1 .
.b.x configure -takefocus 0
tk_focusNext .b
-} {.b.y}
-test focusTcl-5.2 {tkFocusOK procedure, -takefocus 1} {
- deleteWindows
+} -cleanup {
+ cleanup1 .
+} -result {.b.y}
+test focusTcl-5.2 {tkFocusOK procedure, -takefocus 1} -body {
setup1 .
pack forget .b
update
@@ -176,103 +367,119 @@ test focusTcl-5.2 {tkFocusOK procedure, -takefocus 1} {
.b.y configure -takefocus ""
.b.z configure -takefocus ""
list [tk_focusNext .a] [tk_focusNext .b.x]
-} {.c .c}
-test focusTcl-5.3 {tkFocusOK procedure, -takefocus procedure} {
+} -cleanup {
+ cleanup1 .
+} -result {.c .c}
+test focusTcl-5.3 {tkFocusOK procedure, -takefocus procedure} -body {
proc t w {
- if {$w == ".b.x"} {
- return 1
- } elseif {$w == ".b.y"} {
- return ""
- }
- return 0
+ if {$w == ".b.x"} {
+ return 1
+ } elseif {$w == ".b.y"} {
+ return ""
}
- deleteWindows
+ return 0
+ }
+
setup1 .
pack forget .b.y
update
.b configure -takefocus ""
foreach w {.b.x .b.y .b.z .c} {
- $w configure -takefocus t
+ $w configure -takefocus t
}
list [tk_focusNext .a] [tk_focusNext .b.x]
-} {.b.x .d}
-test focusTcl-5.4 {tkFocusOK procedure, -takefocus ""} {
- deleteWindows
+} -cleanup {
+ cleanup1 .
+} -result {.b.x .d}
+test focusTcl-5.4 {tkFocusOK procedure, -takefocus ""} -body {
setup1 .
.b.x configure -takefocus ""
update
tk_focusNext .b
-} {.b.x}
-test focusTcl-5.5 {tkFocusOK procedure, -takefocus "", not mapped} {
- deleteWindows
+} -cleanup {
+ cleanup1 .
+} -result {.b.x}
+test focusTcl-5.5 {tkFocusOK procedure, -takefocus "", not mapped} -body {
setup1 .
.b.x configure -takefocus ""
pack unpack .b.x
update
tk_focusNext .b
-} {.b.y}
-test focusTcl-5.6 {tkFocusOK procedure, -takefocus "", not mapped} {
- deleteWindows
+} -cleanup {
+ cleanup1 .
+} -result {.b.y}
+test focusTcl-5.6 {tkFocusOK procedure, -takefocus "", not mapped} -body {
setup1 .
foreach w {.b.x .b.y .b.z} {
- $w configure -takefocus ""
+ $w configure -takefocus ""
}
pack unpack .b
update
tk_focusNext .b
-} {.c}
-test focusTcl-5.7 {tkFocusOK procedure, -takefocus "", not mapped} {
- deleteWindows
+} -cleanup {
+ cleanup1 .
+} -result {.c}
+test focusTcl-5.7 {tkFocusOK procedure, -takefocus "", not mapped} -body {
setup1 .
.b.y configure -takefocus 1
pack unpack .b.y
update
tk_focusNext .b.x
-} {.b.z}
-test focusTcl-5.8 {tkFocusOK procedure, -takefocus "", not mapped} {
+} -cleanup {
+ cleanup1 .
+} -result {.b.z}
+test focusTcl-5.8 {tkFocusOK procedure, -takefocus "", not mapped} -body {
proc always args {return 1}
- deleteWindows
setup1 .
.b.y configure -takefocus always
pack unpack .b.y
update
tk_focusNext .b.x
-} {.b.y}
-test focusTcl-5.9 {tkFocusOK procedure, -takefocus "", window disabled} {
- deleteWindows
+} -cleanup {
+ cleanup1 .
+} -result {.b.y}
+test focusTcl-5.9 {tkFocusOK procedure, -takefocus "", window disabled} -body {
setup1 .
foreach w {.b.x .b.y .b.z} {
- $w configure -takefocus ""
+ $w configure -takefocus ""
}
update
.b.x configure -state disabled
tk_focusNext .b
-} {.b.y}
-test focusTcl-5.10 {tkFocusOK procedure, -takefocus "", check for bindings} {
- deleteWindows
+} -cleanup {
+ cleanup1 .
+} -result {.b.y}
+test focusTcl-5.10 {tkFocusOK procedure, -takefocus "", check for bindings} -body {
setup1 .
foreach w {.a .b .c .d} {
- $w configure -takefocus ""
+ $w configure -takefocus ""
}
update
bind .a <Key> {foo}
list [tk_focusNext .] [tk_focusNext .a]
-} {.a .b.x}
-test focusTcl-5.11 {tkFocusOK procedure, -takefocus "", check for bindings} {
- deleteWindows
+} -cleanup {
+ cleanup1 .
+} -result {.a .b.x}
+test focusTcl-5.11 {tkFocusOK procedure, -takefocus "", check for bindings} -body {
setup1 .
foreach w {.a .b .c .d} {
- $w configure -takefocus ""
+ $w configure -takefocus ""
}
update
bind Frame <Key> {foo}
list [tk_focusNext .] [tk_focusNext .a]
-} {.a .b}
+} -cleanup {
+ cleanup1 .
+ bind Frame <Key> {}
+} -result {.a .b}
+
-bind Frame <Key> {}
. configure -takefocus 0 -highlightthickness 0
option clear
# cleanup
cleanupTests
return
+
+
+
diff --git a/tests/font.test b/tests/font.test
index 34e4b83..dff9fc9 100644
--- a/tests/font.test
+++ b/tests/font.test
@@ -6,45 +6,18 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
-catch {destroy .b}
-toplevel .b
-wm geom .b +0+0
-update idletasks
-
-proc setup {} {
- catch {destroy .b.f}
- catch {eval font delete [font names]}
- label .b.f
- pack .b.f
- update
-}
-
-label .b.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left -text "0" -font "Courier -12"
-pack .b.l
-canvas .b.c -closeenough 0
-.b.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
-pack .b.c
-update
-
-set ax [winfo reqwidth .b.l]
-set ay [winfo reqheight .b.l]
-proc getsize {} {
- update
- return "[winfo reqwidth .b.l] [winfo reqheight .b.l]"
-}
-proc csetup {{str ""}} {
- focus -force .b.c
- .b.c dchars text 0 end
- .b.c insert text 0 $str
- .b.c focus text
-}
-
-setup
+catch {eval font delete [font names]}
+deleteWindows
+# Toplevel used (in some tests) of the whole file
+toplevel .t
+wm geom .t +0+0
+update idletasks
case [tk windowingsystem] {
x11 {set fixed "fixed"}
@@ -54,195 +27,242 @@ case [tk windowingsystem] {
}
-set times [font actual {times 0} -family]
+# Procedure used in tests: 24.15, 26.*, 28.*, 30.*, 31.*, 32.1
+proc csetup {{str ""}} {
+ focus -force .t.c
+ .t.c dchars text 0 end
+ .t.c insert text 0 $str
+ .t.c focus text
+}
-test font-1.1 {TkFontPkgInit} {
+
+test font-1.1 {TkFontPkgInit} -setup {
catch {interp delete foo}
+} -body {
interp create foo
foo eval {
- load {} Tk
- wm geometry . +0+0
- update
+ load {} Tk
+ wm geometry . +0+0
+ update
}
interp delete foo
-} {}
+} -result {}
-test font-2.1 {TkFontPkgFree} {
+
+test font-2.1 {TkFontPkgFree} -setup {
catch {interp delete foo}
- interp create foo
set x {}
+} -body {
+ interp create foo
# Makes sure that named font was visible only to child interp.
-
foo eval {
- load {} Tk
- wm geometry . +0+0
- button .b -font {times 16} -text "hi"
- pack .b
- font create wiggles -family courier -underline 1
- update
+ load {} Tk
+ wm geometry . +0+0
+ button .b -font {times 16} -text "hi"
+ pack .b
+ font create wiggles -family courier -underline 1
+ update
}
lappend x [catch {font configure wiggles} msg; set msg]
# Tests cancelling the idle handler for TheWorldHasChanged,
# because app goes away before idle serviced.
-
foo eval {
- .b config -font wiggles
- font config wiggles -size 24
- destroy .
+ .b config -font wiggles
+ font config wiggles -size 24
+ destroy .
}
lappend x [foo eval {catch {font families} msg; set msg}]
+} -cleanup {
+ interp delete foo
+} -result {{named font "wiggles" doesn't exist} {can't invoke "font" command: application has been destroyed}}
- interp delete foo
- set x
-} {{named font "wiggles" doesn't exist} {can't invoke "font" command: application has been destroyed}}
+test font-3.1 {font command: general} -body {
+ font
+} -returnCodes error -result {wrong # args: should be "font option ?arg?"}
+test font-3.2 {font command: general} -body {
+ font xyz
+} -returnCodes error -result {bad option "xyz": must be actual, configure, create, delete, families, measure, metrics, or names}
-test font-3.1 {font command: general} {
- list [catch {font} msg] $msg
-} {1 {wrong # args: should be "font option ?arg?"}}
-test font-3.2 {font command: general} {
- list [catch {font xyz} msg] $msg
-} {1 {bad option "xyz": must be actual, configure, create, delete, families, measure, metrics, or names}}
-test font-4.1 {font command: actual: arguments} {
+test font-4.1 {font command: actual: arguments} -body {
# (skip < 0)
- list [catch {font actual xyz -displayof} msg] $msg
-} {1 {value for "-displayof" missing}}
-test font-4.2 {font command: actual: arguments} {
+ font actual xyz -displayof
+} -returnCodes error -result {value for "-displayof" missing}
+test font-4.2 {font command: actual: arguments} -body {
# (objc < 3)
- list [catch {font actual} msg] $msg
-} {1 {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"}}
-test font-4.3 {font command: actual: arguments} {
+ font actual
+} -returnCodes error -result {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"}
+test font-4.3 {font command: actual: arguments} -body {
# (objc - skip > 4) when skip == 0
- list [catch {font actual xyz abc def} msg] $msg
-} {1 {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"}}
-test font-4.4 {font command: actual: displayof specified, so skip to next} {
+ font actual xyz abc def
+} -returnCodes error -result {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"}
+test font-4.4 {font command: actual: displayof specified, so skip to next} -body {
catch {font actual xyz -displayof . -size}
-} {0}
-test font-4.5 {font command: actual: displayof specified, so skip to next} {
+} -result {0}
+test font-4.5 {font command: actual: displayof specified, so skip to next} -body {
lindex [font actual xyz -displayof .] 0
-} {-family}
-test font-4.6 {font command: actual: arguments} {
+} -result {-family}
+test font-4.6 {font command: actual: arguments} -body {
# (objc - skip > 4) when skip == 2
- list [catch {font actual xyz -displayof . abc def} msg] $msg
-} {1 {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"}}
-test font-4.7 {font command: actual: arguments} {noExceed} {
+ font actual xyz -displayof . abc def
+} -returnCodes error -result {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"}
+test font-4.7 {font command: actual: arguments} -constraints noExceed -body {
# (tkfont == NULL)
- list [catch {font actual "\{xyz"} msg] $msg
-} [list 1 "font \"{xyz\" doesn't exist"]
-test font-4.8 {font command: actual: all attributes} {
+ font actual "\{xyz"
+} -returnCodes error -result "font \"{xyz\" doesn't exist"
+test font-4.8 {font command: actual: all attributes} -body {
# not (objc > 3) so objPtr = NULL
lindex [font actual {-family times}] 0
-} {-family}
-test font-4.9 {font command: actual} {unix noExceed} {
+} -result {-family}
+test font-4.9 {font command: actual} -constraints {unix noExceed} -body {
# (objc > 3) so objPtr = objv[3 + skip]
string tolower [font actual {-family times} -family]
-} {times}
-test font-4.10 {font command: actual} win {
+} -result {times}
+test font-4.10 {font command: actual} -constraints win -body {
# (objc > 3) so objPtr = objv[3 + skip]
font actual {-family times} -family
-} {Times New Roman}
-test font-4.11 {font command: bad option} {
- list [catch {font actual xyz -style} msg] $msg
-} {1 {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike}}
+} -result {Times New Roman}
+test font-4.11 {font command: bad option} -body {
+ font actual xyz -style
+} -returnCodes error -result {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike}
-test font-5.1 {font command: configure} {
+
+test font-5.1 {font command: configure} -body {
# (objc < 3)
- list [catch {font configure} msg] $msg
-} {1 {wrong # args: should be "font configure fontname ?options?"}}
-test font-5.2 {font command: configure: non-existent font} {
+ font configure
+} -returnCodes error -result {wrong # args: should be "font configure fontname ?-option value ...?"}
+test font-5.2 {font command: configure: non-existent font} -body {
# (namedHashPtr == NULL)
- list [catch {font configure xyz} msg] $msg
-} {1 {named font "xyz" doesn't exist}}
-test font-5.3 {font command: configure: "deleted" font} {
+ font configure xyz
+} -returnCodes error -result {named font "xyz" doesn't exist}
+test font-5.3 {font command: configure: "deleted" font} -setup {
+ destroy .t.f
+ catch {font delete xyz}
+ pack [label .t.f]
+ update
+} -body {
# (nfPtr->deletePending != 0)
- setup
font create xyz
- .b.f configure -font xyz
+ .t.f configure -font xyz
font delete xyz
- list [catch {font configure xyz} msg] $msg
-} {1 {named font "xyz" doesn't exist}}
-test font-5.4 {font command: configure: get all options} {
+ font configure xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {named font "xyz" doesn't exist}
+test font-5.4 {font command: configure: get all options} -setup {
+ catch {font delete xyz}
+} -body {
# (objc == 3) so objPtr = NULL
- setup
font create xyz -family xyz
lindex [font configure xyz] 1
-} xyz
-test font-5.5 {font command: configure: get one option} {
+} -cleanup {
+ font delete xyz
+} -result xyz
+test font-5.5 {font command: configure: get one option} -setup {
+ catch {eval font delete [font names]}
+} -body {
# (objc == 4) so objPtr = objv[3]
- setup
font create xyz -family xyz
font configure xyz -family
-} xyz
-test font-5.6 {font command: configure: update existing font} {
+ font names
+} -cleanup {
+ font delete xyz
+} -result xyz
+test font-5.6 {font command: configure: update existing font} -setup {
+ catch {font delete xyz}
+} -body {
# else result = ConfigAttributesObj()
- setup
font create xyz
font configure xyz -family xyz
update
font configure xyz -family
-} xyz
-test font-5.7 {font command: configure: bad option} {
- setup
+} -cleanup {
+ font delete xyz
+} -result xyz
+test font-5.7 {font command: configure: bad option} -setup {
+ catch {font delete xyz}
+} -body {
font create xyz
- list [catch {font configure xyz -style} msg] $msg
-} {1 {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike}}
+ font configure xyz -style
+} -cleanup {
+ font delete xyz
+} -returnCodes error -result {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike}
+
-test font-6.1 {font command: create: make up name} {
+test font-6.1 {font command: create: make up name} -setup {
+ catch {eval font delete [font names]}
+} -body {
# (objc < 3) so name = NULL
- setup
font create
font names
-} {font1}
-test font-6.2 {font command: create: name specified} {
+} -cleanup {
+ font delete font1
+} -result {font1}
+test font-6.2 {font command: create: name specified} -setup {
+ catch {eval font delete [font names]}
+} -body {
# not (objc < 3)
- setup
font create xyz
font names
-} {xyz}
-test font-6.3 {font command: create: name not really specified} {
+} -cleanup {
+ font delete xyz
+} -result {xyz}
+test font-6.3 {font command: create: name not really specified} -setup {
+ catch {eval font delete [font names]}
+} -body {
# (name[0] == '-') so name = NULL
- setup
font create -family xyz
font names
-} {font1}
-test font-6.4 {font command: create: generate name} {
+} -cleanup {
+ font delete font1
+} -result {font1}
+test font-6.4 {font command: create: generate name} -setup {
+ catch {eval font delete [font names]}
+} -body {
# (name == NULL)
- setup
font create -family one
font create -family two
font create -family three
font delete font2
font create -family four
font configure font2 -family
-} {four}
-test font-6.5 {font command: create: bad option creating new font} {
+} -cleanup {
+ catch {eval font delete [font names]}
+} -result {four}
+test font-6.5 {font command: create: bad option creating new font} -setup {
+ catch {font delete xyz}
+} -body {
# name was specified so skip = 3
- setup
- list [catch {font create xyz -xyz times} msg] $msg
-} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}}
-test font-6.6 {font command: create: bad option creating new font} {
+ font create xyz -xyz times
+} -returnCodes error -result {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}
+test font-6.6 {font command: create: bad option creating new font} -setup {
+ catch {eval font delete [font names]}
+} -body {
# name was not specified so skip = 2
- setup
- list [catch {font create -xyz times} msg] $msg
-} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}}
-test font-6.7 {font command: create: already exists} {
+ font create -xyz times
+} -returnCodes error -result {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}
+test font-6.7 {font command: create: already exists} -setup {
+ catch {font delete xyz}
+} -body {
# (CreateNamedFont() != TCL_OK)
- setup
font create xyz
- list [catch {font create xyz} msg] $msg
-} {1 {named font "xyz" already exists}}
+ font create xyz
+} -cleanup {
+ font delete xyz
+} -returnCodes error -result {named font "xyz" already exists}
-test font-7.1 {font command: delete: arguments} {
+test font-7.1 {font command: delete: arguments} -body {
# (objc < 3)
- list [catch {font delete} msg] $msg
-} {1 {wrong # args: should be "font delete fontname ?fontname ...?"}}
-test font-7.2 {font command: delete: loop test} {
+ font delete
+} -returnCodes error -result {wrong # args: should be "font delete fontname ?fontname ...?"}
+test font-7.2 {font command: delete: loop test} -setup {
+ catch {eval font delete [font names]}
+ set x {}
+} -body {
# for (i = 2; i < objc; i++)
- setup
- set x {}
font create a -underline 1
font create b -underline 1
font create c -underline 1
@@ -251,11 +271,14 @@ test font-7.2 {font command: delete: loop test} {
lappend x [lsort [font names]]
font delete a e c b
lappend x [lsort [font names]]
-} {{a b c d e} d}
-test font-7.3 {font command: delete: loop test} {
+} -cleanup {
+ catch {eval font delete [font names]}
+} -result {{a b c d e} d}
+test font-7.3 {font command: delete: loop test} -setup {
+ catch {eval font delete [font names]}
+ set x {}
+} -body {
# (namedHashPtr == NULL) in middle of loop
- setup
- set x {}
font create a -underline 1
font create b -underline 1
font create c -underline 1
@@ -264,299 +287,440 @@ test font-7.3 {font command: delete: loop test} {
lappend x [lsort [font names]]
catch {font delete a d q c e b}
lappend x [lsort [font names]]
-} {{a b c d e} {b c e}}
-test font-7.4 {font command: delete: non-existent} {
+} -cleanup {
+ catch {eval font delete [font names]}
+} -result {{a b c d e} {b c e}}
+test font-7.4 {font command: delete: non-existent} -setup {
+ catch {font delete xyz}
+} -body {
# (namedHashPtr == NULL)
- setup
- list [catch {font delete xyz} msg] $msg
-} {1 {named font "xyz" doesn't exist}}
-test font-7.5 {font command: delete: mark for later deletion} {
+ font delete xyz
+} -returnCodes error -result {named font "xyz" doesn't exist}
+test font-7.5 {font command: delete: mark for later deletion} -setup {
+ destroy .t.f
+ catch {font delete xyz}
+ pack [label .t.f]
+ update
+} -body {
# (nfPtr->refCount != 0)
- setup
font create xyz
- .b.f configure -font xyz
+ .t.f configure -font xyz
font delete xyz
font actual xyz
- list [catch {font configure xyz} msg] $msg [.b.f cget -font]
-} {1 {named font "xyz" doesn't exist} xyz}
-test font-7.6 {font command: delete: actually delete} {
+ font configure xyz
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {named font "xyz" doesn't exist}
+test font-7.6 {font command: delete: mark for later deletion} -setup {
+ destroy .t.f
+ catch {font delete xyz}
+ pack [label .t.f]
+ update
+} -body {
+ # (nfPtr->refCount != 0)
+ font create xyz
+ .t.f configure -font xyz
+ font delete xyz
+ font actual xyz
+ catch {font configure xyz}
+ .t.f cget -font
+} -cleanup {
+ destroy .t.f
+} -result xyz
+test font-7.7 {font command: delete: actually delete} -setup {
+ catch {font delete xyz}
+} -body {
# not (nfPtr->refCount != 0)
- setup
font create xyz -underline 1
font delete xyz
- catch {font config xyz}
-} {1}
-setup
+ font config xyz
+} -returnCodes error -match glob -result {*}
-test font-8.1 {font command: families: arguments} {
+
+test font-8.1 {font command: families: arguments} -body {
# (skip < 0)
- list [catch {font families -displayof} msg] $msg
-} {1 {value for "-displayof" missing}}
-test font-8.2 {font command: families: arguments} {
+ font families -displayof
+} -returnCodes error -result {value for "-displayof" missing}
+test font-8.2 {font command: families: arguments} -body {
# (objc - skip != 2) when skip == 0
- list [catch {font families xyz} msg] $msg
-} {1 {wrong # args: should be "font families ?-displayof window?"}}
-test font-8.3 {font command: families: arguments} {
+ font families xyz
+} -returnCodes error -result {wrong # args: should be "font families ?-displayof window?"}
+test font-8.3 {font command: families: arguments} -body {
# (objc - skip != 2) when skip == 2
- list [catch {font families -displayof . xyz} msg] $msg
-} {1 {wrong # args: should be "font families ?-displayof window?"}}
-test font-8.4 {font command: families} {
+ font families -displayof . xyz
+} -returnCodes error -result {wrong # args: should be "font families ?-displayof window?"}
+test font-8.4 {font command: families} -body {
# TkpGetFontFamilies()
regexp -nocase times [font families]
-} {1}
+} -result 1
+
-test font-9.1 {font command: measure: arguments} {
+test font-9.1 {font command: measure: arguments} -body {
# (skip < 0)
- list [catch {expr {[font measure xyz -displayof]>0}} msg] $msg
-} {0 1}
-test font-9.2 {font command: measure: arguments} {
+ expr {[font measure xyz -displayof] > 0}
+} -returnCodes ok -result 1
+test font-9.2 {font command: measure: arguments} -body {
# (objc - skip != 4)
- list [catch {font measure} msg] $msg
-} {1 {wrong # args: should be "font measure font ?-displayof window? text"}}
-test font-9.3 {font command: measure: arguments} {
+ font measure
+} -returnCodes error -result {wrong # args: should be "font measure font ?-displayof window? text"}
+test font-9.3 {font command: measure: arguments} -body {
# (objc - skip != 4)
- list [catch {font measure xyz abc def} msg] $msg
-} {1 {wrong # args: should be "font measure font ?-displayof window? text"}}
-test font-9.4 {font command: measure: arguments} {noExceed} {
+ font measure xyz abc def
+} -returnCodes error -result {wrong # args: should be "font measure font ?-displayof window? text"}
+test font-9.4 {font command: measure: arguments} -constraints noExceed -body {
# (tkfont == NULL)
- list [catch {font measure "\{xyz" abc} msg] $msg
-} [list 1 "font \"{xyz\" doesn't exist"]
-test font-9.5 {font command: measure} {
+ font measure "\{xyz" abc
+} -returnCodes error -result "font \"{xyz\" doesn't exist"
+test font-9.5 {font command: measure} -body {
# Tk_TextWidth()
- expr [font measure $fixed "abcdefg"]==[font measure $fixed "a"]*7
-} {1}
-test font-9.6 {font command: measure -d} {
- list [catch {expr {[font measure $fixed -d] > 0}} msg] $msg
-} {0 1}
-test font-9.7 {font command: measure -d with -displayof} {
- list [catch {expr {[font measure $fixed -displayof . -d] > 0}} msg] $msg
-} {0 1}
-test font-9.8 {font command: measure: arguments} {
- list [catch {font measure $fixed -displayof .} msg] $msg
-} {1 {wrong # args: should be "font measure font ?-displayof window? text"}}
-
-test font-10.1 {font command: metrics: arguments} {
- list [catch {font metrics xyz -displayof} msg] $msg
-} {1 {value for "-displayof" missing}}
-test font-10.2 {font command: metrics: arguments} {
+ expr {[font measure $fixed "abcdefg"] == [font measure $fixed "a"]*7 }
+} -result 1
+test font-9.6 {font command: measure -d} -body {
+ expr {[font measure $fixed -d] > 0}
+} -returnCodes ok -result 1
+test font-9.7 {font command: measure -d with -displayof} -body {
+ expr {[font measure $fixed -displayof . -d] > 0}
+} -returnCodes ok -result 1
+test font-9.8 {font command: measure: arguments} -body {
+ font measure $fixed -displayof .
+} -returnCodes error -result {wrong # args: should be "font measure font ?-displayof window? text"}
+
+
+test font-10.1 {font command: metrics: arguments} -body {
+ font metrics xyz -displayof
+} -returnCodes error -result {value for "-displayof" missing}
+test font-10.2 {font command: metrics: arguments} -body {
# (skip < 0)
- list [catch {font metrics xyz -displayof} msg] $msg
-} {1 {value for "-displayof" missing}}
-test font-10.3 {font command: metrics: arguments} {
+ font metrics xyz -displayof
+} -returnCodes error -result {value for "-displayof" missing}
+test font-10.3 {font command: metrics: arguments} -body {
# (objc < 3)
- list [catch {font metrics} msg] $msg
-} {1 {wrong # args: should be "font metrics font ?-displayof window? ?option?"}}
-test font-10.4 {font command: metrics: arguments} {
+ font metrics
+} -returnCodes error -result {wrong # args: should be "font metrics font ?-displayof window? ?option?"}
+test font-10.4 {font command: metrics: arguments} -body {
# (objc - skip) > 4) when skip == 0
- list [catch {font metrics xyz abc def} msg] $msg
-} {1 {wrong # args: should be "font metrics font ?-displayof window? ?option?"}}
-test font-10.5 {font command: metrics: arguments} {
+ font metrics xyz abc def
+} -returnCodes error -result {wrong # args: should be "font metrics font ?-displayof window? ?option?"}
+test font-10.5 {font command: metrics: arguments} -body {
# (objc - skip) > 4) when skip == 2
- list [catch {font metrics xyz -displayof . abc} msg] $msg
-} {1 {bad metric "abc": must be -ascent, -descent, -linespace, or -fixed}}
-test font-10.6 {font command: metrics: bad font} {noExceed} {
+ font metrics xyz -displayof . abc
+} -returnCodes error -result {bad metric "abc": must be -ascent, -descent, -linespace, or -fixed}
+test font-10.6 {font command: metrics: bad font} -constraints noExceed -body {
# (tkfont == NULL)
- list [catch {font metrics "\{xyz"} msg] $msg
-} [list 1 "font \"{xyz\" doesn't exist"]
-test font-10.7 {font command: metrics: get all metrics} {
- # (objc == 3)
+ font metrics "\{xyz"
+} -returnCodes error -result "font \"{xyz\" doesn't exist"
+test font-10.7 {font command: metrics: get all metrics} -setup {
catch {unset a}
+} -body {
+ # (objc == 3)
array set a [font metrics {-family xyz}]
- set x [lsort [array names a]]
+ lsort [array names a]
+} -cleanup {
unset a
- set x
-} {-ascent -descent -fixed -linespace}
-test font-10.8 {font command: metrics: bad metric} {
+} -result {-ascent -descent -fixed -linespace}
+test font-10.8 {font command: metrics: bad metric} -body {
# (Tcl_GetIndexFromObj() != TCL_OK)
- list [catch {font metrics $fixed -xyz} msg] $msg
-} {1 {bad metric "-xyz": must be -ascent, -descent, -linespace, or -fixed}}
-test font-10.9 {font command: metrics: get individual metrics} {
+ font metrics $fixed -xyz
+} -returnCodes error -result {bad metric "-xyz": must be -ascent, -descent, -linespace, or -fixed}
+test font-10.9 {font command: metrics: get individual metrics} -body {
font metrics $fixed -ascent
font metrics $fixed -descent
font metrics $fixed -linespace
font metrics $fixed -fixed
-} {1}
+} -result 1
+
-test font-11.1 {font command: names: arguments} {
+test font-11.1 {font command: names: arguments} -body {
# (objc != 2)
- list [catch {font names xyz} msg] $msg
-} {1 {wrong # args: should be "font names"}}
-test font-11.2 {font command: names: loop test: no passes} {
- setup
+ font names xyz
+} -returnCodes error -result {wrong # args: should be "font names"}
+test font-11.2 {font command: names: loop test: no passes} -setup {
+ catch {eval font delete [font names]}
+} -body {
font names
-} {}
-test font-11.3 {font command: names: loop test: one pass} {
- setup
+} -result {}
+test font-11.3 {font command: names: loop test: one pass} -setup {
+ catch {eval font delete [font names]}
+} -body {
font create
font names
-} {font1}
-test font-11.4 {font command: names: loop test: multiple passes} {
- setup
+} -result {font1}
+test font-11.4 {font command: names: loop test: multiple passes} -setup {
+ catch {eval font delete [font names]}
+} -body {
font create xyz
font create abc
font create def
lsort [font names]
-} {abc def xyz}
-test font-11.5 {font command: names: skip deletePending fonts} {
- # (nfPtr->deletePending == 0)
- setup
+} -cleanup {
+ catch {eval font delete [font names]}
+} -result {abc def xyz}
+test font-11.5 {font command: names: skip deletePending fonts} -setup {
+ destroy .t.f
+ catch {eval font delete [font names]}
+ pack [label .t.f]
+ update
set x {}
+} -body {
+ # (nfPtr->deletePending == 0)
font create xyz
font create abc
lappend x [lsort [font names]]
- .b.f config -font xyz
+ .t.f config -font xyz
font delete xyz
lappend x [font names]
-} {{abc xyz} abc}
+} -cleanup {
+ catch {eval font delete [font names]}
+} -result {{abc xyz} abc}
-test font-12.1 {UpdateDependantFonts procedure: no users} {
+
+test font-12.1 {UpdateDependantFonts procedure: no users} -setup {
+ catch {font delete xyz}
+} -body {
# (nfPtr->refCount == 0)
- setup
font create xyz
font configure xyz -family times
-} {}
-test font-12.2 {UpdateDependantFonts procedure: pings the widgets} {
- setup
+} -cleanup {
+ font delete xyz
+} -result {}
+test font-12.2 {UpdateDependantFonts procedure: pings the widgets} -setup {
+ destroy .t.f
+ catch {font delete xyz}
+ pack [label .t.f]
+ update
+} -body {
font create xyz -family times -size 20
- .b.f config -font xyz -text "abcd" -padx 0 -bd 0 -highlightthickness 0
+ .t.f config -font xyz -text "abcd" -padx 0 -bd 0 -highlightthickness 0
set a1 [font measure xyz "abcd"]
update
- set b1 [winfo reqwidth .b.f]
+ set b1 [winfo reqwidth .t.f]
font configure xyz -family helvetica -size 20
set a2 [font measure xyz "abcd"]
update
- set b2 [winfo reqwidth .b.f]
+ set b2 [winfo reqwidth .t.f]
expr {$a1==$b1 && $a2==$b2}
-} {1}
+} -cleanup {
+ destroy .t.f
+ font delete xyz
+} -result {1}
+
-test font-13.1 {CreateNamedFont: new named font} {
+test font-13.1 {CreateNamedFont: new named font} -setup {
+ catch {font delete xyz}
+ set x {}
+} -body {
# not (new == 0)
- setup
- set x {}
lappend x [font names]
font create xyz
lappend x [font names]
-} {{} xyz}
-test font-13.2 {CreateNamedFont: named font already exists} {
+} -cleanup {
+ font delete xyz
+} -result {{} xyz}
+test font-13.2 {CreateNamedFont: named font already exists} -setup {
+ catch {font delete xyz}
+} -body {
# (new == 0)
- setup
font create xyz
- list [catch {font create xyz} msg] $msg
-} {1 {named font "xyz" already exists}}
-test font-13.3 {CreateNamedFont: named font already exists} {
+ font create xyz
+} -cleanup {
+ font delete xyz
+} -returnCodes error -result {named font "xyz" already exists}
+test font-13.3 {CreateNamedFont: named font already exists} -setup {
+ catch {font delete xyz}
+} -body {
# (nfPtr->deletePending == 0)
- setup
font create xyz
- list [catch {font create xyz} msg] $msg
-} {1 {named font "xyz" already exists}}
-test font-13.4 {CreateNamedFont: recreate "deleted" font} {
+ font create xyz
+} -cleanup {
+ font delete xyz
+} -returnCodes error -result {named font "xyz" already exists}
+test font-13.4 {CreateNamedFont: recreate "deleted" font} -setup {
+ destroy .t.f
+ catch {font delete xyz}
+ pack [label .t.f]
+ update
+} -body {
# not (nfPtr->deletePending == 0)
- setup
font create xyz -family times
- .b.f configure -font xyz
+ .t.f configure -font xyz
font delete xyz
font create xyz -family courier
font configure xyz -family
-} {courier}
+} -cleanup {
+ font delete xyz
+ destroy .t.f
+} -result {courier}
+
+
+test font-14.1 {Tk_GetFont procedure} -body {
+} -result {}
-test font-14.1 {Tk_GetFont procedure} {
-} {}
-test font-15.1 {Tk_AllocFontFromObj - converting internal reps} testfont {
+test font-15.1 {Tk_AllocFontFromObj - converting internal reps} -constraints {
+ testfont
+} -setup {
+ destroy .b1 .b2
+} -body {
set x {Times 16}
lindex $x 0
- destroy .b1 .b2
button .b1 -font $x
lindex $x 0
testfont counts {Times 16}
-} {{1 0}}
-test font-15.2 {Tk_AllocFontFromObj - discard stale font} testfont {
- set x {Times 16}
+} -cleanup {
+ destroy .b1 .b2
+} -result {{1 0}}
+test font-15.2 {Tk_AllocFontFromObj - discard stale font} -constraints {
+ testfont
+} -setup {
destroy .b1 .b2
+ set result {}
+} -body {
+ set x {Times 16}
button .b1 -font $x
destroy .b1
- set result {}
lappend result [testfont counts {Times 16}]
button .b2 -font $x
lappend result [testfont counts {Times 16}]
-} {{} {{1 1}}}
-test font-15.3 {Tk_AllocFontFromObj - reuse existing font} testfont {
- set x {Times 16}
+} -cleanup {
+ destroy .b2
+} -result {{} {{1 1}}}
+test font-15.3 {Tk_AllocFontFromObj - reuse existing font} -constraints {
+ testfont
+} -setup {
destroy .b1 .b2
- button .b1 -font $x
set result {}
+} -body {
+ set x {Times 16}
+ button .b1 -font $x
lappend result [testfont counts {Times 16}]
button .b2 -font $x
pack .b1 .b2 -side top
lappend result [testfont counts {Times 16}]
-} {{{1 1}} {{2 1}}}
-test font-15.4 {Tk_AllocFontFromObj procedure: bump ref count} {
+} -cleanup {
+ destroy .b1 .b2
+} -result {{{1 1}} {{2 1}}}
+test font-15.4 {Tk_AllocFontFromObj procedure: bump ref count} -setup {
+ destroy .t.f
+ pack [label .t.f]
+ update
+} -body {
# (new == 0)
- setup
- .b.f config -font {-family fixed}
+ .t.f config -font {-family fixed}
lindex [font actual {-family fixed}] 0
-} {-family}
-test font-15.5 {Tk_AllocFontFromObj procedure: get named font} {
+} -cleanup {
+ destroy .t.f
+} -result {-family}
+test font-15.5 {Tk_AllocFontFromObj procedure: get named font} -setup {
+ destroy .t.f
+ catch {font delete xyz}
+ pack [label .t.f]
+ update
+} -body {
# (namedHashPtr != NULL)
- setup
font create xyz
- .b.f config -font xyz
-} {}
-test font-15.6 {Tk_AllocFontFromObj procedure: not a named font} {
+ .t.f config -font xyz
+} -cleanup {
+ destroy .t.f
+ font delete xyz
+} -result {}
+test font-15.6 {Tk_AllocFontFromObj procedure: not a named font} -setup {
+ destroy .t.f
+ pack [label .t.f]
+ update
+} -body {
# not (namedHashPtr != NULL)
- setup
- .b.f config -font {times 20}
-} {}
-test font-15.7 {Tk_AllocFontFromObj procedure: get native font} unix {
+ .t.f config -font {times 20}
+} -cleanup {
+ destroy .t.f
+} -result {-family} -result {}
+test font-15.7 {Tk_AllocFontFromObj procedure: get native font} -constraints {
+ unix
+} -setup {
+ destroy .t.f
+ pack [label .t.f]
+ update
+} -body {
# not (fontPtr == NULL)
- setup
- .b.f config -font fixed
-} {}
-test font-15.8 {Tk_AllocFontFromObj procedure: get native font} win {
+ .t.f config -font fixed
+} -result {}
+test font-15.8 {Tk_AllocFontFromObj procedure: get native font} -constraints {
+ win
+} -setup {
+ destroy .t.f
+ catch {eval font delete [font names]}
+ pack [label .t.f]
+ update
+} -body {
# not (fontPtr == NULL)
- setup
- .b.f config -font oemfixed
-} {}
-test font-15.10 {Tk_AllocFontFromObj procedure: get attribute font} {
+ .t.f config -font oemfixed
+} -cleanup {
+ destroy .t.f
+} -result {}
+test font-15.9 {Tk_AllocFontFromObj procedure: get attribute font} -setup {
+ destroy .t.f
+ pack [label .t.f]
+ update
+} -body {
# (fontPtr == NULL)
- list [catch {.b.f config -font {xxx yyy zzz}} msg] $msg
-} {1 {expected integer but got "yyy"}}
-test font-15.11 {Tk_AllocFontFromObj procedure: no match} {noExceed} {
+ .t.f config -font {xxx yyy zzz}
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {expected integer but got "yyy"}
+test font-15.10 {Tk_AllocFontFromObj procedure: no match} -constraints noExceed -body {
# (ParseFontNameObj() != TCL_OK)
- list [catch {font actual "\{xyz"} msg] $msg
-} [list 1 "font \"{xyz\" doesn't exist"]
-test font-15.12 {Tk_AllocFontFromObj procedure: get attribute font} {
+ font actual "\{xyz"
+} -returnCodes error -result "font \"{xyz\" doesn't exist"
+test font-15.11 {Tk_AllocFontFromObj procedure: get attribute font} -body {
# not (ParseFontNameObj() != TCL_OK)
lindex [font actual {plan 9}] 0
-} {-family}
-test font-15.13 {Tk_AllocFontFromObj procedure: setup tab width} {
+} -result {-family}
+test font-15.12 {Tk_AllocFontFromObj procedure: setup tab width} -setup {
+ destroy .l
+} -body {
# Tk_MeasureChars(fontPtr, "0", ...)
label .l -bd 0 -padx 0 -highlightthickness 0 -font $fixed -text "a\tb"
update
- set x [winfo reqwidth .l]
- destroy .l
- set x
-} [expr [font measure $fixed "0"]*9]
-test font-15.14 {Tk_AllocFontFromObj procedure: underline position} {
+ set res1 [winfo reqwidth .l]
+ set res2 [expr [font measure $fixed "0"]*9]
+ expr {$res1 eq $res2}
+} -cleanup {
+ destroy .l
+} -result 1
+test font-15.13 {Tk_AllocFontFromObj procedure: underline position} -setup {
+ destroy .t.f
+ pack [label .t.f]
+ update
+} -body {
# (fontPtr->underlineHeight == 0) because size was < 10
- setup
- .b.f config -text "underline" -font "times -8 underline"
+ .t.f config -text "underline" -font "times -8 underline"
update
-} {}
+} -cleanup {
+ destroy .t.f
+} -result {}
-test font-16.1 {Tk_NameOfFont procedure} {
- setup
- .b.f config -font -family\ fixed
- .b.f cget -font
-} {-family fixed}
-test font-17.1 {Tk_FreeFontFromObj - reference counts} testfont {
- set x {Courier 12}
+test font-16.1 {Tk_NameOfFont procedure} -setup {
+ destroy .t.f
+ pack [label .t.f]
+ update
+} -body {
+ .t.f config -font -family\ fixed
+ .t.f cget -font
+} -cleanup {
+ destroy .t.f
+} -result {-family fixed}
+
+
+test font-17.1 {Tk_FreeFontFromObj - reference counts} -constraints {
+ testfont
+} -setup {
destroy .b1 .b2 .b3
+ set result {}
+} -body {
+ set x {Courier 12}
button .b1 -font $x
button .b3 -font $x
button .b2 -font $x
- set result {}
lappend result [testfont counts {Courier 12}]
destroy .b1
lappend result [testfont counts {Courier 12}]
@@ -564,61 +728,83 @@ test font-17.1 {Tk_FreeFontFromObj - reference counts} testfont {
lappend result [testfont counts {Courier 12}]
destroy .b3
lappend result [testfont counts {Courier 12}]
-} {{{3 1}} {{2 1}} {{1 1}} {}}
-test font-17.2 {Tk_FreeFont procedure: one ref} {
+} -result {{{3 1}} {{2 1}} {{1 1}} {}}
+test font-17.2 {Tk_FreeFont procedure: one ref} -setup {
+ destroy .t.f
+ pack [label .t.f]
+ update
+} -body {
# (fontPtr->refCount == 0)
- setup
- .b.f config -font {-family fixed}
- destroy .b.f
-} {}
-test font-17.3 {Tk_FreeFont procedure: multiple ref} {
+ .t.f config -font {-family fixed}
+ destroy .t.f
+} -result {}
+test font-17.3 {Tk_FreeFont procedure: multiple ref} -setup {
+ destroy .t.f .t.b
+ pack [label .t.f]
+ update
+} -body {
# not (fontPtr->refCount == 0)
- setup
- .b.f config -font {-family fixed}
- button .b.b -font {-family fixed}
- destroy .b.f
- set x [.b.b cget -font]
- destroy .b.b
- set x
-} {-family fixed}
-test font-17.4 {Tk_FreeFont procedure: named font} {
+ .t.f config -font {-family fixed}
+ button .t.b -font {-family fixed}
+ destroy .t.f
+ .t.b cget -font
+} -cleanup {
+ destroy .t.b
+} -result {-family fixed}
+test font-17.4 {Tk_FreeFont procedure: named font} -setup {
+ destroy .t.f
+ catch {eval font delete [font names]}
+ pack [label .t.f]
+ update
+} -body {
# (fontPtr->namedHashPtr != NULL)
- setup
font create xyz
- .b.f config -font xyz
- destroy .b.f
+ .t.f config -font xyz
+ destroy .t.f
font names
-} {xyz}
-test font-17.5 {Tk_FreeFont procedure: named font} {
+} -result {xyz}
+test font-17.5 {Tk_FreeFont procedure: named font} -setup {
+ destroy .t.f
+ catch {font delete xyz}
+ pack [label .t.f]
+ update
+} -body {
# not (fontPtr->refCount == 0)
- setup
font create xyz -underline 1
- .b.f config -font xyz
+ .t.f config -font xyz
font delete xyz
set x [font actual xyz -underline]
- destroy .b.f
+ destroy .t.f
list [font actual xyz -underline] $x
-} {0 1}
-test font-17.6 {Tk_FreeFont procedure: named font not deleted yet} {
- setup
+} -result {0 1}
+test font-17.6 {Tk_FreeFont procedure: named font not deleted yet} -setup {
+ destroy .t.f .t.b
+ catch {font delete xyz}
+ pack [label .t.f]
+ update
+} -body {
font create xyz
- .b.f config -font xyz
- button .b.b -font xyz
+ .t.f config -font xyz
+ button .t.b -font xyz
font delete xyz
set x [font actual xyz]
- destroy .b.b
+ destroy .t.b
list [lindex [font actual xyz] 0] [lindex $x 0]
-} {-family -family}
+} -cleanup {
+ destroy .t.f
+} -result {-family -family}
-test font-18.1 {FreeFontObjProc} testfont {
+
+test font-18.1 {FreeFontObjProc} -constraints testfont -setup {
destroy .b1
+ set result {}
+} -body {
set x [format {Courier 12}]
button .b1 -font $x
set y [format {Courier 12}]
.b1 configure -font $y
set z [format {Courier 12}]
.b1 configure -font $z
- set result {}
lappend result [testfont counts {Courier 12}]
set x red
lappend result [testfont counts {Courier 12}]
@@ -627,275 +813,864 @@ test font-18.1 {FreeFontObjProc} testfont {
destroy .b1
lappend result [testfont counts {Courier 12}]
set y bogus
- set result
-} {{{1 3}} {{1 2}} {{1 1}} {}}
+ return $result
+} -result {{{1 3}} {{1 2}} {{1 1}} {}}
+
-test font-19.1 {Tk_FontId} {
- .b.f config -font "times 20"
+test font-19.1 {Tk_FontId} -setup {
+ destroy .t.f
+ pack [label .t.f]
update
-} {}
+} -body {
+ .t.f config -font "times 20"
+ update
+} -cleanup {
+ destroy .t.f
+} -result {}
+
-test font-20.1 {Tk_GetFontMetrics procedure} {
- button .b.w1 -text abc
- entry .b.w2 -text abcd
+test font-20.1 {Tk_GetFontMetrics procedure} -setup {
+ destroy .t.w1 .t.w2
+} -body {
+ button .t.w1 -text abc
+ entry .t.w2 -text abcd
update
- destroy .b.w1 .b.w2
-} {}
+ destroy .t.w1 .t.w2
+} -result {}
+
+# Procedure used in 21.* tests
proc psfontname {name} {
- set a [.b.c itemcget text -font]
- .b.c itemconfig text -text "We need text" -font $name
- set post [.b.c postscript]
- .b.c itemconfig text -font $a
+ destroy .t.c
+ canvas .t.c -closeenough 0
+ .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
+ pack .t.c
+ update
+ set a [.t.c itemcget text -font]
+ .t.c itemconfig text -text "We need text" -font $name
+ set post [.t.c postscript]
+ .t.c itemconfig text -font $a
set end [string first "findfont" $post]
incr end -2
set post [string range $post [expr $end-70] $end]
set start [string first "gsave" $post]
+ destroy .t.c
return [string range $post [expr $start+7] end]
}
-test font-21.1 {Tk_PostscriptFontName procedure: native} unix {
+test font-21.1 {Tk_PostscriptFontName procedure: native} -constraints {
+ unix
+} -body {
set x [font actual {{itc avant garde} 10} -family]
if {[string match *avant*garde $x]} {
- psfontname "{itc avant garde} 10"
+ psfontname "{itc avant garde} 10"
} else {
- set x {AvantGarde-Book}
+ set x {AvantGarde-Book}
}
-} {AvantGarde-Book}
-test font-21.2 {Tk_PostscriptFontName procedure: native} win {
+} -result {AvantGarde-Book}
+test font-21.2 {Tk_PostscriptFontName procedure: native} -constraints {
+ win
+} -body {
psfontname "arial 10"
-} {Helvetica}
-test font-21.3 {Tk_PostscriptFontName procedure: native} win {
+} -result {Helvetica}
+test font-21.3 {Tk_PostscriptFontName procedure: native} -constraints {
+ win
+} -body {
psfontname "{times new roman} 10"
-} {Times-Roman}
-test font-21.4 {Tk_PostscriptFontName procedure: native} win {
+} -result {Times-Roman}
+test font-21.4 {Tk_PostscriptFontName procedure: native} -constraints {
+ win
+} -body {
psfontname "{courier new} 10"
-} {Courier}
-test font-21.8 {Tk_PostscriptFontName procedure: spaces} unix {
+} -result {Courier}
+test font-21.5 {Tk_PostscriptFontName procedure: spaces} -constraints {
+ unix
+} -body {
set x [font actual {{lucida bright} 10} -family]
if {[string match lucida*bright $x]} {
- psfontname "{lucida bright} 10"
+ psfontname "{lucida bright} 10"
} else {
- set x {LucidaBright}
+ set x {LucidaBright}
}
-} {LucidaBright}
-test font-21.9 {Tk_PostscriptFontName procedure: spaces} unix {
+} -result {LucidaBright}
+test font-21.6 {Tk_PostscriptFontName procedure: spaces} -constraints {
+ unix
+} -body {
psfontname "{new century schoolbook} 10"
-} {NewCenturySchlbk-Roman}
-set i 10
-foreach p {
- {font-21.10 "avantgarde"
- AvantGarde-Book AvantGarde-Demi
- AvantGarde-BookOblique AvantGarde-DemiOblique}
- {font-21.11 "bookman"
- Bookman-Light Bookman-Demi Bookman-LightItalic Bookman-DemiItalic}
- {font-21.12 "courier"
- Courier Courier-Bold Courier-Oblique Courier-BoldOblique}
- {font-21.13 "helvetica"
- Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique}
- {font-21.14 "new century schoolbook"
- NewCenturySchlbk-Roman NewCenturySchlbk-Bold
- NewCenturySchlbk-Italic NewCenturySchlbk-BoldItalic}
- {font-21.15 "palatino"
- Palatino-Roman Palatino-Bold Palatino-Italic Palatino-BoldItalic}
- {font-21.16 "symbol"
- Symbol Symbol Symbol Symbol}
- {font-21.17 "times"
- Times-Roman Times-Bold Times-Italic Times-BoldItalic}
- {font-21.18 "zapfchancery"
- ZapfChancery-MediumItalic ZapfChancery-MediumItalic
- ZapfChancery-MediumItalic ZapfChancery-MediumItalic}
- {font-21.19 "zapfdingbats"
- ZapfDingbats ZapfDingbats ZapfDingbats ZapfDingbats}
-} {
- set values [lassign $p testName family]
- test $testName {Tk_PostscriptFontName procedure: exhaustive} unix {
- set x {}
- set j 0
- foreach slant {roman italic} {
- foreach weight {normal bold} {
- set name [list $family 12 $slant $weight]
- if {[font actual $name -family] == $family} {
- lappend x [psfontname $name]
- } else {
- lappend x [lindex $values $j]
- }
- incr j
- }
- }
- set x
- } $values
-}
-foreach p {
- {font-21.20 "arial"
- Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique}
- {font-21.21 "courier new"
- Courier Courier-Bold Courier-Oblique Courier-BoldOblique}
- {font-21.22 "helvetica"
- Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique}
- {font-21.23 "symbol"
- Symbol Symbol-Bold Symbol-Italic Symbol-BoldItalic}
- {font-21.24 "times new roman"
- Times-Roman Times-Bold Times-Italic Times-BoldItalic}
-} {
- set values [lassign $p testName family]
- test $testName {Tk_PostscriptFontName procedure: exhaustive} win {
- set x {}
- foreach slant {roman italic} {
- foreach weight {normal bold} {
- lappend x [psfontname [list $family 12 "$slant $weight"]]
- }
- }
- set x
- } $values
-}
+} -result {NewCenturySchlbk-Roman}
+
+test font-21.7 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {avantgarde 12 roman normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "avantgarde"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x AvantGarde-Book
+ }
+} -result {AvantGarde-Book}
+test font-21.8 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {avantgarde 12 roman bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "avantgarde"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x AvantGarde-Demi
+ }
+} -result {AvantGarde-Demi}
+test font-21.9 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {avantgarde 12 italic normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "avantgarde"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x AvantGarde-BookOblique
+ }
+} -result {AvantGarde-BookOblique}
+test font-21.10 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {avantgarde 12 italic bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "avantgarde"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x AvantGarde-DemiOblique
+ }
+} -result {AvantGarde-DemiOblique}
+
+test font-21.11 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {bookman 12 roman normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "bookman"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Bookman-Light
+ }
+} -result {Bookman-Light}
+test font-21.12 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {bookman 12 roman bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "bookman"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Bookman-Demi
+ }
+} -result {Bookman-Demi}
+test font-21.13 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {bookman 12 italic normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "bookman"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Bookman-LightItalic
+ }
+} -result {Bookman-LightItalic}
+test font-21.14 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {bookman 12 italic bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "bookman"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Bookman-DemiItalic
+ }
+} -result {Bookman-DemiItalic}
+
+test font-21.15 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {courier 12 roman normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "courier"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Courier
+ }
+} -result {Courier}
+test font-21.16 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {courier 12 roman bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "courier"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Courier-Bold
+ }
+} -result {Courier-Bold}
+test font-21.17 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {courier 12 italic normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "courier"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Courier-Oblique
+ }
+} -result {Courier-Oblique}
+test font-21.18 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {courier 12 italic bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "courier"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Courier-BoldOblique
+ }
+} -result {Courier-BoldOblique}
+
+test font-21.19 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {helvetica 12 roman normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "helvetica"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Helvetica
+ }
+} -result {Helvetica}
+test font-21.20 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {helvetica 12 roman bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "helvetica"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Helvetica-Bold
+ }
+} -result {Helvetica-Bold}
+test font-21.21 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {helvetica 12 italic normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "helvetica"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Helvetica-Oblique
+ }
+} -result {Helvetica-Oblique}
+test font-21.22 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {helvetica 12 italic bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "helvetica"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Helvetica-BoldOblique
+ }
+} -result {Helvetica-BoldOblique}
+
+test font-21.23 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {{new century schoolbook} 12 roman normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "new century schoolbook"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x NewCenturySchlbk-Roman
+ }
+} -result {NewCenturySchlbk-Roman}
+test font-21.24 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {{new century schoolbook} 12 roman bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "new century schoolbook"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x NewCenturySchlbk-Bold
+ }
+} -result {NewCenturySchlbk-Bold}
+test font-21.25 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {{new century schoolbook} 12 italic normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "new century schoolbook"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x NewCenturySchlbk-Italic
+ }
+} -result {NewCenturySchlbk-Italic}
+test font-21.26 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {{new century schoolbook} 12 italic bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "new century schoolbook"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x NewCenturySchlbk-BoldItalic
+ }
+} -result {NewCenturySchlbk-BoldItalic}
+
+test font-21.27 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {palatino 12 roman normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "palatino"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Palatino-Roman
+ }
+} -result {Palatino-Roman}
+test font-21.28 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {palatino 12 roman bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "palatino"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Palatino-Bold
+ }
+} -result {Palatino-Bold}
+test font-21.29 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {palatino 12 italic normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "palatino"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Palatino-Italic
+ }
+} -result {Palatino-Italic}
+test font-21.30 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {palatino 12 italic bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "palatino"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Palatino-BoldItalic
+ }
+} -result {Palatino-BoldItalic}
+
+test font-21.31 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {symbol 12 roman normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "symbol"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Symbol
+ }
+} -result {Symbol}
+test font-21.32 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {symbol 12 roman bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "symbol"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Symbol
+ }
+} -result {Symbol}
+test font-21.33 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {symbol 12 italic normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "symbol"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Symbol
+ }
+} -result {Symbol}
+test font-21.34 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {symbol 12 italic bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "symbol"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Symbol
+ }
+} -result {Symbol}
+
+test font-21.35 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {times 12 roman normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "times"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Times-Roman
+ }
+} -result {Times-Roman}
+test font-21.36 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {times 12 roman bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "times"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Times-Bold
+ }
+} -result {Times-Bold}
+test font-21.37 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {times 12 italic normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "times"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Times-Italic
+ }
+} -result {Times-Italic}
+test font-21.38 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {times 12 italic bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "times"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x Times-BoldItalic
+ }
+} -result {Times-BoldItalic}
+
+test font-21.39 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {zapfchancery 12 roman normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "zapfchancery"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x ZapfChancery-MediumItalic
+ }
+} -result {ZapfChancery-MediumItalic}
+test font-21.40 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {zapfchancery 12 roman bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "zapfchancery"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x ZapfChancery-MediumItalic
+ }
+} -result {ZapfChancery-MediumItalic}
+test font-21.41 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {zapfchancery 12 italic normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "zapfchancery"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x ZapfChancery-MediumItalic
+ }
+} -result {ZapfChancery-MediumItalic}
+test font-21.42 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {zapfchancery 12 italic bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "zapfchancery"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x ZapfChancery-MediumItalic
+ }
+} -result {ZapfChancery-MediumItalic}
+
+test font-21.43 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {zapfdingbats 12 roman normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "zapfdingbats"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x ZapfDingbats
+ }
+} -result {ZapfDingbats}
+test font-21.44 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {zapfdingbats 12 roman bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "zapfdingbats"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x ZapfDingbats
+ }
+} -result {ZapfDingbats}
+test font-21.45 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {zapfdingbats 12 italic normal}
+ if {[font actual {avantgarde 12 roman normal} -family] == "zapfdingbats"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x ZapfDingbats
+ }
+} -result {ZapfDingbats}
+test font-21.46 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ unix
+} -body {
+ set name {zapfdingbats 12 italic bold}
+ if {[font actual {avantgarde 12 roman normal} -family] == "zapfdingbats"} {
+ set x [psfontname avantgarde 12 roman normal]
+ } else {
+ set x ZapfDingbats
+ }
+} -result {ZapfDingbats}
+
+test font-21.47 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {arial 12 roman normal}]
+} -result {Helvetica}
+test font-21.48 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {arial 12 roman bold}]
+} -result {Helvetica-Bold}
+test font-21.49 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {arial 12 italic normal}]
+} -result {Helvetica-Oblique}
+test font-21.50 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {arial 12 italic bold}]
+} -result {Helvetica-BoldOblique}
+
+test font-21.51 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {{courier new} 12 roman normal}]
+} -result {Courier}
+test font-21.52 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {{courier new} 12 roman bold}]
+} -result {Courier-Bold}
+test font-21.53 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {{courier new} 12 italic normal}]
+} -result {Courier-Oblique}
+test font-21.54 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {{courier new} 12 italic bold}]
+} -result {Courier-BoldOblique}
+
+test font-21.55 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {helvetica 12 roman normal}]
+} -result {Helvetica}
+test font-21.56 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {helvetica 12 roman bold}]
+} -result {Helvetica-Bold}
+test font-21.57 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {helvetica 12 italic normal}]
+} -result {Helvetica-Oblique}
+test font-21.58 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {helvetica 12 italic bold}]
+} -result {Helvetica-BoldOblique}
+
+test font-21.59 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {symbol 12 roman normal}]
+} -result {Symbol}
+test font-21.60 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {symbol 12 roman bold}]
+} -result {Symbol-Bold}
+test font-21.61 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {symbol 12 italic normal}]
+} -result {Symbol-Italic}
+test font-21.62 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {symbol 12 italic bold}]
+} -result {Symbol-BoldItalic}
+
+test font-21.63 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {{times new roman} 12 roman normal}]
+} -result {Times-Roman}
+test font-21.64 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {{times new roman} 12 roman bold}]
+} -result {Times-Bold}
+test font-21.65 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {{times new roman} 12 italic normal}]
+} -result {Times-Italic}
+test font-21.66 {Tk_PostscriptFontName procedure: exhaustive} -constraints {
+ win
+} -body {
+ set x [psfontname {{times new roman} 12 italic bold}]
+} -result {Times-BoldItalic}
+
+
+test font-22.1 {Tk_TextWidth procedure} -setup {
+ destroy .t.l
+} -body {
+ label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
+ -text "0" -font "Courier -12"
+ pack .t.l
+ set ax [winfo reqwidth .t.l]
+ expr {[font measure [.t.l cget -font] "000"] eq $ax*3}
+} -cleanup {
+ destroy .t.l
+} -result 1
+
+
+test font-23.1 {Tk_UnderlineChars procedure} -setup {
+ destroy .t.t
+} -body {
+ text .t.t
+ .t.t insert 1.0 abc\tdefg
+ .t.t tag config sel -underline 1
+ .t.t tag add sel 1.0 end
+ update
+} -cleanup {
+ destroy .t.t
+} -result {}
-test font-22.1 {Tk_TextWidth procedure} {
- font measure [.b.l cget -font] "000"
-} [expr $ax*3]
-test font-23.1 {Tk_UnderlineChars procedure} {
- text .b.t
- .b.t insert 1.0 abc\tdefg
- .b.t tag config sel -underline 1
- .b.t tag add sel 1.0 end
- update
-} {}
-
-setup
-test font-24.1 {Tk_ComputeTextLayout: empty string} {
- .b.l config -text ""
-} {}
-test font-24.2 {Tk_ComputeTextLayout: simple string} {
- .b.l config -text "000"
- getsize
-} "[expr $ax*3] $ay"
-test font-24.3 {Tk_ComputeTextLayout: find special chars} {
- .b.l config -text "000\n000"
- getsize
-} "[expr $ax*3] [expr $ay*2]"
-test font-24.4 {Tk_ComputeTextLayout: calls Tk_MeasureChars} {
- .b.l config -text "000\n000"
- getsize
-} "[expr $ax*3] [expr $ay*2]"
-test font-24.5 {Tk_ComputeTextLayout: break line} {
- .b.l config -text "000\t00000" -wrap [expr 9*$ax]
- set x [getsize]
- .b.l config -wrap 0
- set x
-} "[expr 8*$ax] [expr 2*$ay]"
-test font-24.6 {Tk_ComputeTextLayout: normal ended on special char} {
- .b.l config -text "000\n000"
-} {}
-test font-24.7 {Tk_ComputeTextLayout: special char was \n} {
- .b.l config -text "000\n0000"
- getsize
-} "[expr $ax*4] [expr $ay*2]"
-test font-24.8 {Tk_ComputeTextLayout: special char was \t} {
- .b.l config -text "000\t00"
- getsize
-} "[expr $ax*10] $ay"
-test font-24.9 {Tk_ComputeTextLayout: tab didn't cause break} {
+# Data used in 24.* tests
+destroy .t.l
+label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
+ -text "0" -font "Courier -12"
+pack .t.l
+update
+set ax [winfo reqwidth .t.l]
+set ay [winfo reqheight .t.l]
+test font-24.1 {Tk_ComputeTextLayout: empty string} -body {
+ .t.l config -text ""
+} -result {}
+test font-24.2 {Tk_ComputeTextLayout: simple string} -body {
+ .t.l config -text "000"
+ update
+ list [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}] \
+ [expr {[winfo reqheight .t.l] eq $ay}]
+} -result {1 1}
+test font-24.3 {Tk_ComputeTextLayout: find special chars} -body {
+ .t.l config -text "000\n000"
+ update
+ list [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}] \
+ [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}]
+} -result {1 1}
+test font-24.4 {Tk_ComputeTextLayout: calls Tk_MeasureChars} -body {
+ .t.l config -text "000\n000"
+ update
+ list [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}] \
+ [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}]
+} -result {1 1}
+test font-24.5 {Tk_ComputeTextLayout: break line} -body {
+ .t.l config -text "000\t00000" -wrap [expr 9 * $ax]
+ update
+ list [expr {[winfo reqwidth .t.l] eq [expr {$ax * 8}]}] \
+ [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}]
+} -cleanup {
+ .t.l config -wrap 0
+} -result {1 1}
+test font-24.6 {Tk_ComputeTextLayout: normal ended on special char} -body {
+ .t.l config -text "000\n000"
+} -result {}
+test font-24.7 {Tk_ComputeTextLayout: special char was \n} -body {
+ .t.l config -text "000\n0000"
+ update
+ list [expr {[winfo reqwidth .t.l] eq [expr {$ax * 4}]}] \
+ [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}]
+} -result {1 1}
+test font-24.8 {Tk_ComputeTextLayout: special char was \t} -body {
+ .t.l config -text "000\t00"
+ update
+ list [expr {[winfo reqwidth .t.l] eq [expr {$ax * 10}]}] \
+ [expr {[winfo reqheight .t.l] eq $ay}]
+} -result {1 1}
+test font-24.9 {Tk_ComputeTextLayout: tab didn't cause break} -body {
set x {}
- .b.l config -text "000\t000"
- lappend x [getsize]
- .b.l config -text "000\t000" -wrap [expr 100*$ax]
- lappend x [getsize]
- .b.l config -wrap 0
- set x
-} "{[expr $ax*11] $ay} {[expr $ax*11] $ay}"
-test font-24.10 {Tk_ComputeTextLayout: tab caused break} {
+ .t.l config -text "000\t000"
+ update
+ lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 11}]}]
+ lappend x [expr {[winfo reqheight .t.l] eq $ay}]
+ .t.l config -text "000\t000" -wrap [expr 100 * $ax]
+ update
+ lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 11}]}]
+ lappend x [expr {[winfo reqheight .t.l] eq $ay}]
+ return $x
+} -cleanup {
+ .t.l config -wrap 0
+} -result {1 1 1 1}
+test font-24.10 {Tk_ComputeTextLayout: tab caused break} -body {
set x {}
- .b.l config -text "000\t"
- lappend x [getsize]
- .b.l config -text "000\t00" -wrap [expr $ax*6]
- lappend x [getsize]
- .b.l config -wrap 0
- set x
-} "{[expr $ax*3] $ay} {[expr $ax*3] [expr $ay*2]}"
-test font-24.11 {Tk_ComputeTextLayout: absorb spaces at eol} {
+ .t.l config -text "000\t"
+ update
+ lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}]
+ lappend x [expr {[winfo reqheight .t.l] eq $ay}]
+ .t.l config -text "000\t00" -wrap [expr $ax * 6]
+ update
+ lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}]
+ lappend x [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}]
+ return $x
+} -cleanup {
+ .t.l config -wrap 0
+} -result {1 1 1 1}
+test font-24.11 {Tk_ComputeTextLayout: absorb spaces at eol} -body {
set x {}
- .b.l config -text "000 000" -wrap [expr $ax*5]
- lappend x [getsize]
- .b.l config -text "000 "
- lappend x [getsize]
- .b.l config -wrap 0
- set x
-} "{[expr $ax*3] [expr $ay*2]} {[expr $ax*3] $ay}"
-test font-24.12 {Tk_ComputeTextLayout: append non-printing spaces to chunk} {
+ .t.l config -text "000 000" -wrap [expr {$ax * 5}]
+ update
+ lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}]
+ lappend x [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}]
+ .t.l config -text "000 "
+ update
+ lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}]
+ lappend x [expr {[winfo reqheight .t.l] eq $ay}]
+ return $x
+} -cleanup {
+ .t.l config -wrap 0
+} -result {1 1 1 1}
+test font-24.12 {Tk_ComputeTextLayout: append non-printing spaces to chunk} -body {
set x {}
- .b.l config -text "000 0000" -wrap [expr $ax*5]
- lappend x [getsize]
- .b.l config -text "000\t00 0000" -wrap [expr $ax*12]
- lappend x [getsize]
- .b.l config -wrap 0
- set x
-} "{[expr $ax*4] [expr $ay*2]} {[expr $ax*10] [expr $ay*2]}"
-test font-24.13 {Tk_ComputeTextLayout: many lines -> realloc line array} {
- .b.l config -text "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n"
- getsize
-} "1 [expr $ay*129]"
-test font-24.14 {Tk_ComputeTextLayout: text ended with \n} {
- list [.b.l config -text "0000"; getsize] [.b.l config -text "0000\n"; getsize]
-} "{[expr $ax*4] $ay} {[expr $ax*4] [expr $ay*2]}"
-test font-24.15 {Tk_ComputeTextLayout: justification} {
- csetup "000\n00000"
+ .t.l config -text "000 0000" -wrap [expr {$ax * 5}]
+ update
+ lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 4}]}]
+ lappend x [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}]
+ .t.l config -text "000\t00 0000" -wrap [expr {$ax * 12}]
+ update
+ lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 10}]}]
+ lappend x [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}]
+ return $x
+} -cleanup {
+ .t.l config -wrap 0
+} -result {1 1 1 1}
+test font-24.13 {Tk_ComputeTextLayout: many lines -> realloc line array} -body {
+ .t.l config -text "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n"
+ update
+ list [expr {[winfo reqwidth .t.l] eq 1}] \
+ [expr {[winfo reqheight .t.l] eq [expr {$ay * 129}]}]
+} -result {1 1}
+test font-24.14 {Tk_ComputeTextLayout: text ended with \n} -body {
+ set x {}
+ .t.l config -text "0000"
+ update
+ lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 4}]}]
+ lappend x [expr {[winfo reqheight .t.l] eq $ay}]
+ .t.l config -text "0000\n"
+ update
+ lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 4}]}]
+ lappend x [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}]
+ return $x
+} -result {1 1 1 1}
+destroy .t.l
+
+test font-24.15 {Tk_ComputeTextLayout: justification} -setup {
set x {}
- .b.c itemconfig text -just left
- lappend x [.b.c index text @[expr $ax*2],0]
- .b.c itemconfig text -just center
- lappend x [.b.c index text @[expr $ax*2],0]
- .b.c itemconfig text -just right
- lappend x [.b.c index text @[expr $ax*2],0]
- .b.c itemconfig text -just left
- set x
-} {2 1 0}
-
-test font-25.1 {Tk_FreeTextLayout procedure} {
- setup
- .b.f config -text foo
- .b.f config -text boo
-} {}
+ destroy .t.c
+ canvas .t.c -closeenough 0
+ .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
+ pack .t.c
+ update
+} -body {
+ csetup "000\n00000"
+ .t.c itemconfig text -just left
+ lappend x [.t.c index text @[expr $ax*2],0]
+ .t.c itemconfig text -just center
+ lappend x [.t.c index text @[expr $ax*2],0]
+ .t.c itemconfig text -just right
+ lappend x [.t.c index text @[expr $ax*2],0]
+ .t.c itemconfig text -just left
+ return $x
+} -cleanup {
+ destroy .t.c
+} -result {2 1 0}
+
+
+test font-25.1 {Tk_FreeTextLayout procedure} -setup {
+ destroy .t.f
+ pack [label .t.f]
+ update
+} -body {
+ .t.f config -text foo
+ .t.f config -text boo
+} -cleanup {
+ destroy .t.f
+} -result {}
-test font-26.1 {Tk_DrawTextLayout procedure: auto-detect last char} {
- .b.f config -text foo
-} {}
-test font-26.2 {Tk_DrawTextLayout procedure: multiple chunks} {
+
+# Canvas created for tests: 26.*
+destroy .t.c
+canvas .t.c -closeenough 0
+.t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
+pack .t.c
+update
+test font-26.1 {Tk_DrawTextLayout procedure: auto-detect last char} -setup {
+ destroy .t.f
+ pack [label .t.f]
+ update
+} -body {
+ .t.f config -text foo
+} -cleanup {
+ destroy .t.f
+} -result {}
+test font-26.2 {Tk_DrawTextLayout procedure: multiple chunks} -body {
csetup "000\t00\n000"
-} {}
-test font-26.3 {Tk_DrawTextLayout: draw subset of chunk: numDisplay <= 0} {
+} -result {}
+test font-26.3 {Tk_DrawTextLayout: draw subset of chunk: numDisplay <= 0} -body {
csetup "000\t00"
- .b.c select from text 3
- .b.c select to text 5
-} {}
-test font-26.4 {Tk_DrawTextLayout: draw subset of chunk: firstChar <= 0} {
- .b.c select from text 3
- .b.c select to text 5
-} {}
-test font-26.5 {Tk_DrawTextLayout: draw subset of chunk: firstChar > 0} {
- .b.c select from text 2
- .b.c select to text 2
-} {}
-test font-26.6 {Tk_DrawTextLayout: draw subset of chunk: lastChar < numChars} {
- .b.c select from text 4
- .b.c select to text 4
-} {}
-
-test font-27.1 {Tk_UnderlineTextLayout procedure: no underline chosen} {
- .b.f config -text "foo" -under -1
-} {}
-test font-27.2 {Tk_UnderlineTextLayout procedure: underline not visible} {
- .b.f config -text "000 00000" -wrap [expr $ax*7] -under 10
-} {}
-test font-27.3 {Tk_UnderlineTextLayout procedure: underline is visible} {
- .b.f config -text "000 00000" -wrap [expr $ax*7] -under 5
- .b.f config -wrap -1 -under -1
-} {}
-
-test font-28.1 {Tk_PointToChar procedure: above all lines} {
+ .t.c select from text 3
+ .t.c select to text 5
+} -result {}
+test font-26.4 {Tk_DrawTextLayout: draw subset of chunk: firstChar <= 0} -body {
+ csetup "000\t00"
+ .t.c select from text 3
+ .t.c select to text 5
+} -result {}
+test font-26.5 {Tk_DrawTextLayout: draw subset of chunk: firstChar > 0} -body {
+ csetup "000\t00"
+ .t.c select from text 2
+ .t.c select to text 2
+} -result {}
+test font-26.6 {Tk_DrawTextLayout: draw subset of chunk: lastChar < numChars} -body {
+ csetup "000\t00"
+ .t.c select from text 4
+ .t.c select to text 4
+} -result {}
+destroy .t.c
+
+# Label used in 27.* tests
+destroy .t.f
+pack [label .t.f]
+update
+test font-27.1 {Tk_UnderlineTextLayout procedure: no underline chosen} -body {
+ .t.f config -text "foo" -under -1
+} -result {}
+test font-27.2 {Tk_UnderlineTextLayout procedure: underline not visible} -body {
+ .t.f config -text "000 00000" -wrap [expr $ax*7] -under 10
+} -result {}
+test font-27.3 {Tk_UnderlineTextLayout procedure: underline is visible} -body {
+ .t.f config -text "000 00000" -wrap [expr $ax*7] -under 5
+ .t.f config -wrap -1 -under -1
+} -result {}
+destroy .t.f
+
+
+
+# Canvas created for tests: 28.*
+destroy .t.c
+canvas .t.c -closeenough 0
+.t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
+pack .t.c
+update
+test font-28.1 {Tk_PointToChar procedure: above all lines} -body {
csetup "000"
- .b.c index text @-1,0
-} {0}
-test font-28.2 {Tk_PointToChar procedure: no chars} {
+ .t.c index text @-1,0
+} -result {0}
+test font-28.2 {Tk_PointToChar procedure: no chars} -body {
# After fixing the following bug:
#
# In canvas text item, it was impossible to click to position the
@@ -905,206 +1680,277 @@ test font-28.2 {Tk_PointToChar procedure: no chars} {
# index of 1 if TextLayout contained 0 characters.
csetup ""
- .b.c index text @100,100
-} {0}
-test font-28.3 {Tk_PointToChar procedure: loop test} {
+ .t.c index text @100,100
+} -result {0}
+test font-28.3 {Tk_PointToChar procedure: loop test} -body {
csetup "000\n000\n000\n000"
- .b.c index text @10000,0
-} {3}
-test font-28.4 {Tk_PointToChar procedure: intersect line} {
+ .t.c index text @10000,0
+} -result {3}
+test font-28.4 {Tk_PointToChar procedure: intersect line} -body {
csetup "000\n000\n000"
- .b.c index text @0,$ay
-} {4}
-test font-28.5 {Tk_PointToChar procedure: to the left of all chunks} {
- .b.c index text @-100,$ay
-} {4}
-test font-28.6 {Tk_PointToChar procedure: past any possible chunk} {
- .b.c index text @100000,$ay
-} {7}
-test font-28.7 {Tk_PointToChar procedure: which chunk on this line} {
+ .t.c index text @0,$ay
+} -result {4}
+test font-28.5 {Tk_PointToChar procedure: to the left of all chunks} -body {
+ csetup "000\n000\n000"
+ .t.c index text @-100,$ay
+} -result {4}
+test font-28.6 {Tk_PointToChar procedure: past any possible chunk} -body {
+ csetup "000\n000\n000"
+ .t.c index text @100000,$ay
+} -result {7}
+test font-28.7 {Tk_PointToChar procedure: which chunk on this line} -body {
csetup "000\n000\t000\t000\n000"
- .b.c index text @[expr $ax*2],$ay
-} {6}
-test font-28.8 {Tk_PointToChar procedure: which chunk on this line} {
+ .t.c index text @[expr $ax*2],$ay
+} -result {6}
+test font-28.8 {Tk_PointToChar procedure: which chunk on this line} -body {
csetup "000\n000\t000\t000\n000"
- .b.c index text @[expr $ax*10],$ay
-} {10}
-test font-28.9 {Tk_PointToChar procedure: in special chunk} {
+ .t.c index text @[expr $ax*10],$ay
+} -result {10}
+test font-28.9 {Tk_PointToChar procedure: in special chunk} -body {
csetup "000\n000\t000\t000\n000"
- .b.c index text @[expr $ax*6],$ay
-} {7}
-test font-28.10 {Tk_PointToChar procedure: past all chars in chunk} {
+ .t.c index text @[expr $ax*6],$ay
+} -result {7}
+test font-28.10 {Tk_PointToChar procedure: past all chars in chunk} -body {
csetup "000 0000000"
- .b.c itemconfig text -width [expr $ax*5]
- set x [.b.c index text @[expr $ax*5],0]
- .b.c itemconfig text -width 0
- set x
-} {3}
-test font-28.11 {Tk_PointToChar procedure: below all chunks} {
+ .t.c itemconfig text -width [expr $ax*5]
+ set x [.t.c index text @[expr $ax*5],0]
+ .t.c itemconfig text -width 0
+ return $x
+} -result {3}
+test font-28.11 {Tk_PointToChar procedure: below all chunks} -body {
csetup "000 0000000"
- .b.c index text @0,1000000
-} {11}
-
-test font-29.1 {Tk_CharBBox procedure: index < 0} {
- .b.f config -text "000" -underline -1
-} {}
-test font-29.2 {Tk_CharBBox procedure: loop} {
- .b.f config -text "000\t000\t000\t000" -underline 9
-} {}
-test font-29.3 {Tk_CharBBox procedure: special char} {
- .b.f config -text "000\t000\t000" -underline 7
-} {}
-test font-29.4 {Tk_CharBBox procedure: normal char} {
- .b.f config -text "000" -underline 1
-} {}
-test font-29.5 {Tk_CharBBox procedure: right edge of bbox truncated} {
- .b.f config -text "0 0000" -wrap [expr $ax*4] -under 2
- .b.f config -wrap 0
-} {}
-test font-29.6 {Tk_CharBBox procedure: bbox pegged to right edge} {
- .b.f config -text "0 0000" -wrap [expr $ax*4] -under 3
- .b.f config -wrap 0
-} {}
-
-.b.c bind all <Enter> {lappend x [.b.c index current @%x,%y]}
-
-test font-30.1 {Tk_DistanceToTextLayout procedure: loop once} {
+ .t.c index text @0,1000000
+} -result {11}
+destroy .t.c
+
+
+# Label used in 29.* tests
+destroy .t.f
+pack [label .t.f]
+update
+test font-29.1 {Tk_CharBBox procedure: index < 0} -body {
+ .t.f config -text "000" -underline -1
+} -result {}
+test font-29.2 {Tk_CharBBox procedure: loop} -body {
+ .t.f config -text "000\t000\t000\t000" -underline 9
+} -result {}
+test font-29.3 {Tk_CharBBox procedure: special char} -body {
+ .t.f config -text "000\t000\t000" -underline 7
+} -result {}
+test font-29.4 {Tk_CharBBox procedure: normal char} -body {
+ .t.f config -text "000" -underline 1
+} -result {}
+test font-29.5 {Tk_CharBBox procedure: right edge of bbox truncated} -body {
+ .t.f config -text "0 0000" -wrap [expr $ax*4] -under 2
+ .t.f config -wrap 0
+} -result {}
+test font-29.6 {Tk_CharBBox procedure: bbox pegged to right edge} -body {
+ .t.f config -text "0 0000" -wrap [expr $ax*4] -under 3
+ .t.f config -wrap 0
+} -result {}
+destroy .t.f
+
+
+
+# Canvas created for tests: 30.*
+destroy .t.c
+canvas .t.c -closeenough 0
+.t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
+pack .t.c
+update
+test font-30.1 {Tk_DistanceToTextLayout procedure: loop once} -body {
csetup "000\n000\n000"
+ .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
set x {}
- event generate .b.c <Leave>
- event generate .b.c <Enter> -x 0 -y 0
- set x
-} {0}
-test font-30.2 {Tk_DistanceToTextLayout procedure: loop multiple} {
+ event generate .t.c <Leave>
+ event generate .t.c <Enter> -x 0 -y 0
+ return $x
+} -cleanup {
+ bind all <Enter> {}
+} -result {0}
+test font-30.2 {Tk_DistanceToTextLayout procedure: loop multiple} -body {
csetup "000\n000\n000"
+ .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
set x {}
- event generate .b.c <Leave>
- event generate .b.c <Enter> -x $ax -y $ay
- set x
-} {5}
-test font-30.3 {Tk_DistanceToTextLayout procedure: loop to end} {
+ event generate .t.c <Leave>
+ event generate .t.c <Enter> -x $ax -y $ay
+ return $x
+} -cleanup {
+ bind all <Enter> {}
+} -result {5}
+test font-30.3 {Tk_DistanceToTextLayout procedure: loop to end} -body {
csetup "000\n0\n000"
+ .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
set x {}
- event generate .b.c <Leave>
- event generate .b.c <Enter> -x [expr $ax*2] -y $ay
- set x
-} {}
-test font-30.4 {Tk_DistanceToTextLayout procedure: hit a special char (tab)} {
+ event generate .t.c <Leave>
+ event generate .t.c <Enter> -x [expr $ax*2] -y $ay
+ return $x
+} -cleanup {
+ bind all <Enter> {}
+} -result {}
+test font-30.4 {Tk_DistanceToTextLayout procedure: hit a special char (tab)} -body {
csetup "000\t000\n000"
+ .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
set x {}
- event generate .b.c <Leave>
- event generate .b.c <Enter> -x [expr $ax*6] -y 0
- set x
-} {3}
-test font-30.5 {Tk_DistanceToTextLayout procedure: ignore newline} {
+ event generate .t.c <Leave>
+ event generate .t.c <Enter> -x [expr $ax*6] -y 0
+ return $x
+} -cleanup {
+ bind all <Enter> {}
+} -result {3}
+test font-30.5 {Tk_DistanceToTextLayout procedure: ignore newline} -body {
csetup "000\n0\n000"
+ .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
set x {}
- event generate .b.c <Leave>
- event generate .b.c <Enter> -x [expr $ax*2] -y $ay
- set x
-} {}
-test font-30.6 {Tk_DistanceToTextLayout procedure: ignore spaces at eol} {
+ event generate .t.c <Leave>
+ event generate .t.c <Enter> -x [expr $ax*2] -y $ay
+ return $x
+} -cleanup {
+ bind all <Enter> {}
+} -result {}
+test font-30.6 {Tk_DistanceToTextLayout procedure: ignore spaces at eol} -body {
csetup "000\n000 000000000"
- .b.c itemconfig text -width [expr $ax*10]
+ .t.c itemconfig text -width [expr $ax*10]
+ .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
set x {}
- event generate .b.c <Leave>
- event generate .b.c <Enter> -x [expr $ax*5] -y $ay
- .b.c itemconfig text -width 0
- set x
-} {}
-.b.c itemconfig text -justify center
-test font-30.7 {Tk_DistanceToTextLayout procedure: on left side} {
+ event generate .t.c <Leave>
+ event generate .t.c <Enter> -x [expr $ax*5] -y $ay
+ .t.c itemconfig text -width 0
+ return $x
+} -cleanup {
+ bind all <Enter> {}
+} -result {}
+.t.c itemconfig text -justify center
+test font-30.7 {Tk_DistanceToTextLayout procedure: on left side} -body {
csetup "0\n000"
+ .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
set x {}
- event generate .b.c <Leave>
- event generate .b.c <Enter> -x 0 -y 0
- set x
-} {}
-test font-30.8 {Tk_DistanceToTextLayout procedure: on right side} {
+ event generate .t.c <Leave>
+ event generate .t.c <Enter> -x 0 -y 0
+ return $x
+} -cleanup {
+ bind all <Enter> {}
+} -result {}
+test font-30.8 {Tk_DistanceToTextLayout procedure: on right side} -body {
csetup "0\n000"
+ .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
set x {}
- event generate .b.c <Leave>
- event generate .b.c <Enter> -x [expr $ax*2] -y 0
- set x
-} {}
-test font-30.9 {Tk_DistanceToTextLayout procedure: inside line} {
+ event generate .t.c <Leave>
+ event generate .t.c <Enter> -x [expr $ax*2] -y 0
+ return $x
+} -cleanup {
+ bind all <Enter> {}
+} -result {}
+test font-30.9 {Tk_DistanceToTextLayout procedure: inside line} -body {
csetup "0\n000"
+ .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
set x {}
- event generate .b.c <Leave>
- event generate .b.c <Enter> -x $ax -y 0
- set x
-} {0}
-test font-30.10 {Tk_DistanceToTextLayout procedure: above line} {
+ event generate .t.c <Leave>
+ event generate .t.c <Enter> -x $ax -y 0
+ return $x
+} -cleanup {
+ bind all <Enter> {}
+} -result {0}
+test font-30.10 {Tk_DistanceToTextLayout procedure: above line} -body {
csetup "0\n000"
+ .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
set x {}
- event generate .b.c <Leave>
- event generate .b.c <Enter> -x 0 -y 0
- set x
-} {}
-test font-30.11 {Tk_DistanceToTextLayout procedure: below line} {
+ event generate .t.c <Leave>
+ event generate .t.c <Enter> -x 0 -y 0
+ return $x
+} -cleanup {
+ bind all <Enter> {}
+} -result {}
+test font-30.11 {Tk_DistanceToTextLayout procedure: below line} -body {
csetup "000\n0"
+ .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
set x {}
- event generate .b.c <Leave>
- event generate .b.c <Enter> -x 0 -y $ay
- set x
-} {}
-test font-30.12 {Tk_DistanceToTextLayout procedure: in line} {
+ event generate .t.c <Leave>
+ event generate .t.c <Enter> -x 0 -y $ay
+ return $x
+} -cleanup {
+ bind all <Enter> {}
+} -result {}
+test font-30.12 {Tk_DistanceToTextLayout procedure: in line} -body {
csetup "0\n000"
+ .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
set x {}
- event generate .b.c <Leave>
- event generate .b.c <Enter> -x $ax -y $ay
- set x
-} {3}
-.b.c itemconfig text -justify left
-test font-30.13 {Tk_DistanceToTextLayout procedure: exact hit} {
+ event generate .t.c <Leave>
+ event generate .t.c <Enter> -x $ax -y $ay
+ return $x
+} -cleanup {
+ bind all <Enter> {}
+} -result {3}
+.t.c itemconfig text -justify left
+test font-30.13 {Tk_DistanceToTextLayout procedure: exact hit} -body {
csetup "000"
+ .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
set x {}
- event generate .b.c <Leave>
- event generate .b.c <Enter> -x $ax -y 0
- set x
-} {1}
-
-test font-31.1 {Tk_IntersectTextLayout procedure: loop once} {
+ event generate .t.c <Leave>
+ event generate .t.c <Enter> -x $ax -y 0
+ return $x
+} -cleanup {
+ bind all <Enter> {}
+} -result {1}
+destroy .t.c
+
+
+# Canvas created for tests 31.*
+destroy .t.c
+canvas .t.c -closeenough 0
+.t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
+pack .t.c
+update
+test font-31.1 {Tk_IntersectTextLayout procedure: loop once} -body {
csetup "000\n000\n000"
- .b.c find overlapping 0 0 0 0
-} [.b.c find withtag text]
-test font-31.2 {Tk_IntersectTextLayout procedure: loop multiple} {
+ .t.c find overlapping 0 0 0 0
+} -result [.t.c find withtag text]
+test font-31.2 {Tk_IntersectTextLayout procedure: loop multiple} -body {
csetup "000\t000\t000"
- .b.c find overlapping [expr $ax*10] 0 [expr $ax*10] 0
-} [.b.c find withtag text]
-test font-31.3 {Tk_IntersectTextLayout procedure: loop to end} {
+ .t.c find overlapping [expr $ax*10] 0 [expr $ax*10] 0
+} -result [.t.c find withtag text]
+test font-31.3 {Tk_IntersectTextLayout procedure: loop to end} -body {
csetup "0\n000"
- .b.c find overlapping [expr $ax*2] 0 [expr $ax*2] 0
-} {}
-test font-31.4 {Tk_IntersectTextLayout procedure: hit a special char (tab)} {
+ .t.c find overlapping [expr $ax*2] 0 [expr $ax*2] 0
+} -result {}
+test font-31.4 {Tk_IntersectTextLayout procedure: hit a special char (tab)} -body {
csetup "000\t000"
- .b.c find overlapping [expr $ax*6] 0 [expr $ax*6] 0
-} [.b.c find withtag text]
-test font-31.5 {Tk_IntersectTextLayout procedure: ignore newlines} {
+ .t.c find overlapping [expr $ax*6] 0 [expr $ax*6] 0
+} -result [.t.c find withtag text]
+test font-31.5 {Tk_IntersectTextLayout procedure: ignore newlines} -body {
csetup "000\n0\n000"
- .b.c find overlapping $ax $ay $ax $ay
-} {}
-test font-31.6 {Tk_IntersectTextLayout procedure: ignore spaces at eol} {
+ .t.c find overlapping $ax $ay $ax $ay
+} -result {}
+test font-31.6 {Tk_IntersectTextLayout procedure: ignore spaces at eol} -body {
csetup "000\n000 000000000"
- .b.c itemconfig text -width [expr $ax*10]
- set x [.b.c find overlapping [expr $ax*5] $ay [expr $ax*5] $ay]
- .b.c itemconfig text -width 0
- set x
-} {}
-
-test font-32.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} {
+ .t.c itemconfig text -width [expr $ax*10]
+ set x [.t.c find overlapping [expr $ax*5] $ay [expr $ax*5] $ay]
+ .t.c itemconfig text -width 0
+ return $x
+} -result {}
+destroy .t.c
+
+
+test font-32.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} -setup {
+ destroy .t.c
+ canvas .t.c -closeenough 0
+ .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
+ pack .t.c
+ update
+} -body {
# If there were a whole bunch of returns or tabs in a row, then the
# temporary buffer could overflow and write on the stack.
-
csetup "qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm\n"
- .b.c itemconfig text -width 800
- .b.c insert text end "qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm\n"
- .b.c insert text end "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n"
- .b.c insert text end "end"
- set x [.b.c postscript]
+ .t.c itemconfig text -width 800
+ .t.c insert text end "qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm\n"
+ .t.c insert text end "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n"
+ .t.c insert text end "end"
+ set x [.t.c postscript]
set i [string first "(qwerty" $x]
string range $x $i [expr {$i + 278}]
-} {(qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm)]
+} -cleanup {
+ destroy .t.c
+} -result {(qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm)]
[(qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm)]
[()]
[()]
@@ -1139,248 +1985,372 @@ test font-32.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} {
[(end)]
}
-test font-33.1 {Tk_TextWidth procedure} {
-} {}
-test font-34.1 {ConfigAttributesObj procedure: arguments} {
+test font-33.1 {Tk_TextWidth procedure} -body {
+} -result {}
+
+
+test font-34.1 {ConfigAttributesObj procedure: arguments} -setup {
+ catch {font delete xyz}
+} -body {
# (Tcl_GetIndexFromObj() != TCL_OK)
- setup
- list [catch {font create xyz -xyz} msg] $msg
-} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}}
-test font-34.2 {ConfigAttributesObj procedure: arguments} {
+ font create xyz -xyz
+} -returnCodes {
+ error
+} -result {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}
+test font-34.2 {ConfigAttributesObj procedure: arguments} -setup {
+ catch {font delete xyz}
+} -body {
# (objc & 1)
- setup
- list [catch {font create xyz -family} msg] $msg
-} {1 {value for "-family" option missing}}
-foreach p {
- {font-34.3 family xyz times}
- {font-34.4 size 20 40}
- {font-34.5 weight normal bold}
- {font-34.6 slant roman italic}
- {font-34.7 underline 0 1}
- {font-34.8 overstrike 0 1}
-} {
- lassign $p testName opt val1 val2
- test $testName "ConfigAttributesObj procedure: $opt" {
- setup
- set x {}
- font create xyz -$opt $val1
- lappend x [font config xyz -$opt]
- font config xyz -$opt $val2
- lappend x [font config xyz -$opt]
- } [list $val1 $val2]
-}
-foreach p {
- {font-34.9 size xyz {expected integer but got "xyz"}}
- {font-34.10 weight xyz {bad -weight value "xyz": must be normal, or bold}}
- {font-34.11 slant xyz {bad -slant value "xyz": must be roman, or italic}}
- {font-34.12 underline xyz {expected boolean value but got "xyz"}}
- {font-34.13 overstrike xyz {expected boolean value but got "xyz"}}
-} {
- lassign $p testName opt val result
- test $testName "ConfigAttributesObj procedure: $opt" -setup {
- setup
- } -body {
- font create xyz -$opt $val
- } -returnCodes error -result $result
-}
+ font create xyz -family
+} -returnCodes error -result {value for "-family" option missing}
-test font-35.1 {GetAttributeInfoObj procedure: one attribute} {
+test font-34.3 {ConfigAttributesObj procedure: family} -setup {
+ catch {font delete xyz}
+ set x {}
+} -body {
+ font create xyz -family xyz
+ lappend x [font config xyz -family]
+ font config xyz -family times
+ lappend x [font config xyz -family]
+} -cleanup {
+ font delete xyz
+} -result {xyz times}
+test font-34.4 {ConfigAttributesObj procedure: size} -setup {
+ catch {font delete xyz}
+ set x {}
+} -body {
+ font create xyz -size 20
+ lappend x [font config xyz -size]
+ font config xyz -size 40
+ lappend x [font config xyz -size]
+} -cleanup {
+ font delete xyz
+} -result {20 40}
+test font-34.5 {ConfigAttributesObj procedure: weight} -setup {
+ catch {font delete xyz}
+ set x {}
+} -body {
+ font create xyz -weight normal
+ lappend x [font config xyz -weight]
+ font config xyz -weight bold
+ lappend x [font config xyz -weight]
+} -cleanup {
+ font delete xyz
+} -result {normal bold}
+test font-34.6 {ConfigAttributesObj procedure: slant} -setup {
+ catch {font delete xyz}
+ set x {}
+} -body {
+ font create xyz -slant roman
+ lappend x [font config xyz -slant]
+ font config xyz -slant italic
+ lappend x [font config xyz -slant]
+} -cleanup {
+ font delete xyz
+} -result {roman italic}
+test font-34.7 {ConfigAttributesObj procedure: underline} -setup {
+ catch {font delete xyz}
+ set x {}
+} -body {
+ font create xyz -underline 0
+ lappend x [font config xyz -underline]
+ font config xyz -underline 1
+ lappend x [font config xyz -underline]
+} -cleanup {
+ font delete xyz
+} -result {0 1}
+test font-34.8 {ConfigAttributesObj procedure: overstrike} -setup {
+ catch {font delete xyz}
+ set x {}
+} -body {
+ font create xyz -overstrike 0
+ lappend x [font config xyz -overstrike]
+ font config xyz -overstrike 1
+ lappend x [font config xyz -overstrike]
+} -cleanup {
+ font delete xyz
+} -result {0 1}
+
+test font-34.9 {ConfigAttributesObj procedure: size} -body {
+ font create xyz -size xyz
+} -returnCodes error -result {expected integer but got "xyz"}
+test font-34.10 {ConfigAttributesObj procedure: weight} -body {
+ font create xyz -weight xyz
+} -returnCodes error -result {bad -weight value "xyz": must be normal, or bold}
+test font-34.11 {ConfigAttributesObj procedure: slant} -body {
+ font create xyz -slant xyz
+} -returnCodes error -result {bad -slant value "xyz": must be roman, or italic}
+test font-34.12 {ConfigAttributesObj procedure: underline} -body {
+ font create xyz -underline xyz
+} -returnCodes error -result {expected boolean value but got "xyz"}
+test font-34.13 {ConfigAttributesObj procedure: overstrike} -body {
+ font create xyz -overstrike xyz
+} -returnCodes error -result {expected boolean value but got "xyz"}
+
+
+test font-35.1 {GetAttributeInfoObj procedure: one attribute} -setup {
+ catch {font delete xyz}
+} -body {
# (objPtr != NULL)
- setup
font create xyz -family xyz
font config xyz -family
-} {xyz}
+} -cleanup {
+ font delete xyz
+} -result {xyz}
+
-test font-36.1 {GetAttributeInfoObj procedure: unknown attribute} {
+test font-36.1 {GetAttributeInfoObj procedure: unknown attribute} -setup {
+ catch {font delete xyz}
+} -body {
# (Tcl_GetIndexFromObj() != TCL_OK)
- setup
font create xyz
- list [catch {font config xyz -xyz} msg] $msg
-} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}}
-
-test font-37.1 {GetAttributeInfoObj procedure: all attributes} {
- # not (objPtr != NULL)
- setup
+ font config xyz -xyz
+} -cleanup {
+ font delete xyz
+} -returnCodes {
+ error
+} -result {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}
+
+
+test font-37.1 {GetAttributeInfoObj procedure: all attributes} -setup {
+ catch {font delete xyz}
+} -body {
+ # not (objPtr != NULL)
font create xyz -family xyz
font config xyz
-} {-family xyz -size 0 -weight normal -slant roman -underline 0 -overstrike 0}
-set i 4
-foreach p {
- {font-37.2 family xyz xyz}
- {font-37.3 size 20 20}
- {font-37.4 weight normal normal}
- {font-37.5 slant italic italic}
- {font-37.6 underline yes 1}
- {font-37.7 overstrike false 0}
-} {
- lassign $p testName opt val expected
- test $testName "GetAttributeInfo procedure: $opt" -setup {
- setup
- } -body {
- font create xyz -$opt $val
- font config xyz -$opt
- } -result $expected
-}
+} -cleanup {
+ font delete xyz
+} -result {-family xyz -size 0 -weight normal -slant roman -underline 0 -overstrike 0}
+test font-37.2 {GetAttributeInfo procedure: family} -setup {
+ catch {font delete xyz}
+} -body {
+ font create xyz -family xyz
+ font config xyz -family
+} -cleanup {
+ font delete xyz
+} -result {xyz}
+test font-37.3 {GetAttributeInfo procedure: size} -setup {
+ catch {font delete xyz}
+ set x {}
+} -body {
+ font create xyz -size 20
+ font config xyz -size
+} -cleanup {
+ font delete xyz
+} -result {20}
+test font-37.4 {GetAttributeInfo procedure: weight} -setup {
+ catch {font delete xyz}
+ set x {}
+} -body {
+ font create xyz -weight normal
+ font config xyz -weight
+} -cleanup {
+ font delete xyz
+} -result {normal}
+test font-37.5 {GetAttributeInfo procedure: slant} -setup {
+ catch {font delete xyz}
+ set x {}
+} -body {
+ font create xyz -slant italic
+ font config xyz -slant
+} -cleanup {
+ font delete xyz
+} -result {italic}
+test font-37.6 {GetAttributeInfo procedure: underline} -setup {
+ catch {font delete xyz}
+ set x {}
+} -body {
+ font create xyz -underline yes
+ font config xyz -underline
+} -cleanup {
+ font delete xyz
+} -result {1}
+test font-37.7 {GetAttributeInfo procedure: overstrike} -setup {
+ catch {font delete xyz}
+ set x {}
+} -body {
+ font create xyz -overstrike no
+ font config xyz -overstrike
+} -cleanup {
+ font delete xyz
+} -result {0}
+
# In tests below, one field is set to "xyz" so that font name doesn't
# look like a native X font, so that ParseFontNameObj or TkParseXLFD will
# be called.
-setup
-
-test font-38.1 {ParseFontNameObj procedure: begins with -} {
+test font-38.1 {ParseFontNameObj procedure: begins with -} -body {
lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1
-} $times
-test font-38.2 {ParseFontNameObj procedure: begins with -*} {
+} -result [font actual {times 0} -family]
+test font-38.2 {ParseFontNameObj procedure: begins with -*} -body {
lindex [font actual -*-times-xyz-*-*-*-*-*-*-*-*-*-*-*] 1
-} $times
-test font-38.3 {ParseFontNameObj procedure: begins with -, doesn't look like list} {
+} -result [font actual {times 0} -family]
+test font-38.3 {ParseFontNameObj procedure: begins with -, doesn't look like list} -body {
lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1
-} $times
-test font-38.4 {ParseFontNameObj procedure: begins with -, looks like list} {
+} -result [font actual {times 0} -family]
+test font-38.4 {ParseFontNameObj procedure: begins with -, looks like list} -body {
lindex [font actual {-family times}] 1
-} $times
-test font-38.5 {ParseFontNameObj procedure: begins with *} {
+} -result [font actual {times 0} -family]
+test font-38.5 {ParseFontNameObj procedure: begins with *} -body {
lindex [font actual *-times-xyz-*-*-*-*-*-*-*-*-*-*-*] 1
-} $times
-test font-38.6 {ParseFontNameObj procedure: begins with *} {
+} -result [font actual {times 0} -family]
+test font-38.6 {ParseFontNameObj procedure: begins with *} -body {
font actual *-times-xyz -family
-} $times
-test font-38.7 {ParseFontNameObj procedure: arguments} {noExceed} {
- list [catch {font actual "\{xyz"} msg] $msg
-} [list 1 "font \"{xyz\" doesn't exist"]
-test font-38.8 {ParseFontNameObj procedure: arguments} {noExceed} {
- list [catch {font actual ""} msg] $msg
-} {1 {font "" doesn't exist}}
-test font-38.9 {ParseFontNameObj procedure: arguments} {
- list [catch {font actual {times 20 xyz xyz}} msg] $msg
-} {1 {unknown font style "xyz"}}
-test font-38.10 {ParseFontNameObj procedure: arguments} {
- list [catch {font actual {times xyz xyz}} msg] $msg
-} {1 {expected integer but got "xyz"}}
-test font-38.12 {ParseFontNameObj procedure: stylelist loop} {unixOrPc} {
+} -result [font actual {times 0} -family]
+test font-38.7 {ParseFontNameObj procedure: arguments} -constraints noExceed -body {
+ font actual "\{xyz"
+} -returnCodes error -result "font \"{xyz\" doesn't exist"
+test font-38.8 {ParseFontNameObj procedure: arguments} -constraints noExceed -body {
+ font actual ""
+} -returnCodes error -result {font "" doesn't exist}
+test font-38.9 {ParseFontNameObj procedure: arguments} -body {
+ font actual {times 20 xyz xyz}
+} -returnCodes error -result {unknown font style "xyz"}
+test font-38.10 {ParseFontNameObj procedure: arguments} -body {
+ font actual {times xyz xyz}
+} -returnCodes error -result {expected integer but got "xyz"}
+test font-38.11 {ParseFontNameObj procedure: stylelist loop} -constraints {
+ unixOrPc
+} -body {
lrange [font actual {times 12 bold italic overstrike underline}] 4 end
-} {-weight bold -slant italic -underline 1 -overstrike 1}
-test font-38.13 {ParseFontNameObj procedure: stylelist error} {
- list [catch {font actual {times 12 bold xyz}} msg] $msg
-} {1 {unknown font style "xyz"}}
-test font-38.14 "ParseFontNameObj: options with hyphenated family: bug #2791352" -body {
+} -result {-weight bold -slant italic -underline 1 -overstrike 1}
+test font-38.12 {ParseFontNameObj procedure: stylelist error} -body {
+ font actual {times 12 bold xyz}
+} -returnCodes error -result {unknown font style "xyz"}
+test font-38.13 "ParseFontNameObj: options with hyphenated family: bug #2791352" -body {
font actual {-family sans-serif -size 12 -weight bold -slant roman -underline 0 -overstrike 0}
} -returnCodes ok -result [font actual {sans-serif 12 bold}]
-test font-38.15 "ParseFontNameObj: bug #2791352" -body {
+test font-38.14 "ParseFontNameObj: bug #2791352" -body {
font actual {-invalidfont 8 bold}
} -returnCodes error -match glob -result {bad option "-invalidfont": *}
-test font-39.1 {NewChunk procedure: test realloc} {
- .b.f config -text "xxx\nxxx\txxx\nxxx\t\t\t"
-} {}
-test font-40.1 {TkFontParseXLFD procedure: initial dash} {
+test font-39.1 {NewChunk procedure: test realloc} -setup {
+ destroy .t.f
+ pack [label .t.f]
+ update
+} -body {
+ .t.f config -text "xxx\nxxx\txxx\nxxx\t\t\t"
+} -cleanup {
+ destroy .t.f
+} -result {}
+
+
+test font-40.1 {TkFontParseXLFD procedure: initial dash} -body {
font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-* -family
-} $times
-test font-40.2 {TkFontParseXLFD procedure: no initial dash} {
+} -result [font actual {times 0} -family]
+test font-40.2 {TkFontParseXLFD procedure: no initial dash} -body {
font actual *-times-*-*-*-*-*-*-*-*-*-*-*-xyz -family
-} $times
-test font-40.3 {TkFontParseXLFD procedure: not enough fields} {
+} -result [font actual {times 0} -family]
+test font-40.3 {TkFontParseXLFD procedure: not enough fields} -body {
font actual -xyz-times-*-*-* -family
-} $times
-test font-40.4 {TkFontParseXLFD procedure: all fields unspecified} {
+} -result [font actual {times 0} -family]
+test font-40.4 {TkFontParseXLFD procedure: all fields unspecified} -body {
lindex [font actual -xyz-*-*-*-*-*-*-*-*-*-*-*-*-*] 0
-} {-family}
-test font-40.5 {TkFontParseXLFD procedure: all fields specified} {
- lindex [font actual -foundry-times-weight-slant-setwidth-addstyle-10-10-10-10-spacing-avgwidth-registry-encoding] 1
-} $times
-test font-41.1 {TkParseXLFD procedure: arguments} {
+} -result {-family}
+test font-40.5 {TkFontParseXLFD procedure: all fields specified} -body {
+ lindex [font actual \
+ -foundry-times-weight-slant-setwidth-addstyle-10-10-10-10-spacing-avgwidth-registry-encoding] 1
+} -result [font actual {times 0} -family]
+
+
+test font-41.1 {TkParseXLFD procedure: arguments} -body {
# XLFD with bad pointsize: fallback to some system font.
font actual -*-*-*-*-*-*-xyz-*-*-*-*-*-*-*
set x {}
-} {}
-test font-42.1 {TkFontParseXLFD procedure: arguments} {
+} -result {}
+
+
+test font-42.1 {TkFontParseXLFD procedure: arguments} -body {
# XLFD with bad pixelsize: fallback to some system font.
font actual -*-*-*-*-*-*-*-xyz-*-*-*-*-*-*
set x {}
-} {}
-test font-42.2 {TkFontParseXLFD procedure: pixelsize specified} {
+} -result {}
+test font-42.2 {TkFontParseXLFD procedure: pixelsize specified} -body {
font metrics -xyz-times-*-*-*-*-12-*-*-*-*-*-*-* -linespace
set x {}
-} {}
-test font-42.3 {TkFontParseXLFD procedure: weird pixelsize specified} {
+} -result {}
+test font-42.3 {TkFontParseXLFD procedure: weird pixelsize specified} -body {
font metrics {-xyz-times-*-*-*-*-[ 12.0 0 12.0 0]-*-*-*-*-*-*-*} -linespace
set x {}
-} {}
-test font-42.4 {TkFontParseXLFD procedure: pointsize specified} {
+} -result {}
+test font-42.4 {TkFontParseXLFD procedure: pointsize specified} -body {
font metrics -xyz-times-*-*-*-*-*-120-*-*-*-*-*-* -linespace
set x {}
-} {}
-test font-42.5 {TkFontParseXLFD procedure: weird pointsize specified} {
+} -result {}
+test font-42.5 {TkFontParseXLFD procedure: weird pointsize specified} -body {
font metrics {-xyz-times-*-*-*-*-*-[ 12.0 0 12.0 0]-*-*-*-*-*-*} -linespace
set x {}
-} {}
+} -result {}
-test font-43.1 {FieldSpecified procedure: specified vs. non-specified} {
+
+test font-43.1 {FieldSpecified procedure: specified vs. non-specified} -body {
font actual -xyz--*-*-*-*-*-*-*-*-*-*-*-*
font actual -xyz-*-*-*-*-*-*-*-*-*-*-*-*-*
font actual -xyz-?-*-*-*-*-*-*-*-*-*-*-*-*
lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1
-} $times
+} -result [font actual {times 0} -family]
+
-set oldscale [tk scaling]
-tk scaling 0.5
-test font-44.1 {TkFontGetPixels: size < 0} {
+test font-44.1 {TkFontGetPixels: size < 0} -setup {
+ set oldscale [tk scaling]
+} -body {
+ tk scaling 0.5
font actual {times -12} -size
-} {24}
-test font-44.2 {TkFontGetPoints: size >= 0} {noExceed} {
+} -cleanup {
+ tk scaling $oldscale
+} -result {24}
+test font-44.2 {TkFontGetPoints: size >= 0} -constraints noExceed -setup {
+ set oldscale [tk scaling]
+} -body {
+ tk scaling 0.5
font actual {times 12} -size
-} {12}
+} -cleanup {
+ tk scaling $oldscale
+} -result {12}
-tk scaling $oldscale
-test font-45.1 {TkFontGetAliasList: no match} {
+test font-45.1 {TkFontGetAliasList: no match} -body {
font actual {snarky 10} -family
-} [font actual {-size 10} -family]
-test font-45.3 {TkFontGetAliasList: match} win {
+} -result [font actual {-size 10} -family]
+test font-45.2 {TkFontGetAliasList: match} -constraints win -body {
font actual {times 10} -family
-} {Times New Roman}
-test font-45.4 {TkFontGetAliasList: match} {unix noExceed} {
+} -result {Times New Roman}
+test font-45.3 {TkFontGetAliasList: match} -constraints {unix noExceed} -body {
# can fail on Unix systems that have a real "times new roman" font
font actual {{times new roman} 10} -family
-} [font actual {times 10} -family]
+} -result [font actual {times 10} -family]
-test font-46.1 {font actual, with character, no option, no --} \
- -body {
+
+test font-46.1 {font actual, with character, no option, no --} -body {
font actual {times 10} a
- } \
- -match glob \
- -result [list -family [font actual {times 10} -family] -size *\
+} -match glob -result [list -family [font actual {times 10} -family] -size *\
-slant roman -underline 0 -overstrike 0]
-test font-46.2 {font actual, with character introduced by --} \
- -body {
+test font-46.2 {font actual, with character introduced by --} -body {
font actual {times 10} -- -
- } \
- -match glob \
- -result [list -family [font actual {times 10} -family] -size *\
+} -match glob -result [list -family [font actual {times 10} -family] -size *\
-slant roman -underline 0 -overstrike 0]
-test font-46.3 {font actual, with character and option} {
+test font-46.3 {font actual, with character and option} -body {
font actual {times 10} -family a
-} [font actual {times 10} -family]
+} -result [font actual {times 10} -family]
-test font-46.4 {font actual, with character, option and --} {
+test font-46.4 {font actual, with character, option and --} -body {
font actual {times 10} -family -- -
-} [font actual {times 10} -family]
-
-test font-46.5 {font actual, too many chars} {
- list [catch {
- font actual {times 10} 123456789012345678901234567890123456789012345678901
- } result] $result
-} {1 {expected a single character but got "1234567890123456789012345678901234567..."}}
+} -result [font actual {times 10} -family]
-setup
+test font-46.5 {font actual, too many chars} -body {
+ font actual {times 10} 123456789012345678901234567890123456789012345678901
+} -returnCodes error -result {expected a single character but got "1234567890123456789012345678901234567..."}
-destroy .b
# cleanup
cleanupTests
return
+
+
+
+
diff --git a/tests/fontchooser.test b/tests/fontchooser.test
new file mode 100644
index 0000000..4dad5da
--- /dev/null
+++ b/tests/fontchooser.test
@@ -0,0 +1,201 @@
+# Test the "tk::fontchooser" command
+#
+# Copyright (c) 2008 Pat Thoyts
+
+package require tcltest 2.1
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+# the following helper functions are related to the functions used
+# in winDialog.test where they are used to send messages to the win32
+# dialog (hence the wierdness).
+
+proc start {cmd} {
+ set ::tk_dialog {}
+ set ::iter_after 0
+ after 1 $cmd
+}
+proc then {cmd} {
+ set ::command $cmd
+ set ::dialogresult {}
+ set ::testfont {}
+ afterbody
+ vwait ::dialogresult
+ return $::dialogresult
+}
+proc afterbody {} {
+ if {$::tk_dialog == {}} {
+ if {[incr ::iter_after] > 30} {
+ set ::dialogresult ">30 iterations waiting for tk_dialog"
+ return
+ }
+ after 150 {afterbody}
+ return
+ }
+ uplevel #0 {set dialogresult [eval $command]}
+}
+proc Click {button} {
+ switch -exact -- $button {
+ ok { $::tk_dialog.ok invoke }
+ cancel { $::tk_dialog.cancel invoke }
+ apply { $::tk_dialog.apply invoke }
+ default { return -code error "invalid button name \"$button\"" }
+ }
+}
+proc ApplyFont {font} {
+# puts stderr "apply: $font"
+ set ::testfont $font
+}
+
+# -------------------------------------------------------------------------
+
+test fontchooser-1.1 {tk fontchooser: usage} -returnCodes error -body {
+ tk fontchooser -z
+} -result {unknown or ambiguous subcommand "-z": must be configure, hide, or show}
+
+test fontchooser-1.2 {tk fontchooser: usage} -returnCodes error -body {
+ tk fontchooser configure -z
+} -match glob -result {bad option "-z":*}
+
+test fontchooser-1.3 {tk fontchooser: usage} -returnCodes error -body {
+ tk fontchooser configure -parent . -font
+} -result {value for "-font" missing}
+
+test fontchooser-1.4 {tk fontchooser: usage} -returnCodes error -body {
+ tk fontchooser configure -parent . -title
+} -result {value for "-title" missing}
+
+test fontchooser-1.5 {tk fontchooser: usage} -returnCodes error -body {
+ tk fontchooser configure -parent . -command
+} -result {value for "-command" missing}
+
+test fontchooser-1.6 {tk fontchooser: usage} -returnCodes error -body {
+ tk fontchooser configure -title . -parent
+} -result {value for "-parent" missing}
+
+test fontchooser-1.7 {tk fontchooser: usage} -returnCodes error -body {
+ tk fontchooser configure -parent abc
+} -result {bad window path name "abc"}
+
+test fontchooser-1.8 {tk fontchooser: usage} -returnCodes ok -body {
+ tk fontchooser configure -visible
+} -result {0}
+
+test fontchooser-1.9 {tk fontchooser: usage} -returnCodes error -body {
+ tk fontchooser configure -visible 1
+} -match glob -result {*}
+
+# -------------------------------------------------------------------------
+#
+# The remaining tests in this file are only relevant for the script
+# implementation. They can be tested by sourcing the script file but
+# the Tk tests are run with -singleproc 1 and doing this affects the
+# result of later attempts to test the native implementations.
+#
+testConstraint scriptImpl [llength [info proc ::tk::fontchooser::Configure]]
+
+test fontchooser-2.0 {fontchooser -title} -constraints scriptImpl -body {
+ start {
+ tk::fontchooser::Configure -title "Hello"
+ tk::fontchooser::Show
+ }
+ then {
+ set x [wm title $::tk_dialog]
+ Click cancel
+ }
+ set x
+} -result {Hello}
+
+test fontchooser-2.1 {fontchooser -title (cyrillic)} -constraints scriptImpl -body {
+ start {
+ tk::fontchooser::Configure \
+ -title "\u041f\u0440\u0438\u0432\u0435\u0442"
+ tk::fontchooser::Show
+ }
+ then {
+ set x [wm title $::tk_dialog]
+ Click cancel
+ }
+ set x
+} -result "\u041f\u0440\u0438\u0432\u0435\u0442"
+
+test fontchooser-3.0 {fontchooser -parent} -constraints scriptImpl -body {
+ start {
+ tk::fontchooser::Configure -parent .
+ tk::fontchooser::Show
+ }
+ then {
+ set x [winfo parent $::tk_dialog]
+ Click cancel
+ }
+ set x
+} -result {.}
+
+test fontchooser-3.1 {fontchooser -parent (invalid)} -constraints scriptImpl -body {
+ tk::fontchooser::Configure -parent junk
+} -returnCodes error -match glob -result {bad window path *}
+
+test fontchooser-4.0 {fontchooser -font} -constraints scriptImpl -body {
+ start {
+ tk::fontchooser::Configure -command ApplyFont -font courier
+ tk::fontchooser::Show
+ }
+ then {
+ Click cancel
+ }
+ set ::testfont
+} -result {}
+
+test fontchooser-4.1 {fontchooser -font} -constraints scriptImpl -body {
+ start {
+ tk::fontchooser::Configure -command ApplyFont -font courier
+ tk::fontchooser::Show
+ }
+ then {
+ Click ok
+ }
+ expr {$::testfont ne {}}
+} -result {1}
+
+test fontchooser-4.2 {fontchooser -font} -constraints scriptImpl -body {
+ start {
+ tk::fontchooser::Configure -command ApplyFont -font TkDefaultFont
+ tk::fontchooser::Show
+ }
+ then {
+ Click ok
+ }
+ expr {$::testfont ne {}}
+} -result {1}
+
+test fontchooser-4.3 {fontchooser -font} -constraints scriptImpl -body {
+ start {
+ tk::fontchooser::Configure -command ApplyFont -font {times 14 bold}
+ tk::fontchooser::Show
+ }
+ then {
+ Click ok
+ }
+ expr {$::testfont ne {}}
+} -result {1}
+
+test fontchooser-4.4 {fontchooser -font} -constraints scriptImpl -body {
+ start {
+ tk::fontchooser::Configure -command ApplyFont -font {times 14 bold}
+ tk::fontchooser::Show
+ }
+ then {
+ Click ok
+ }
+ lrange $::testfont 1 end
+} -result {14 bold}
+
+# -------------------------------------------------------------------------
+
+cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tests/frame.test b/tests/frame.test
index affdac6..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 a9e9dc0..456427f 100644
--- a/tests/imgPPM.test
+++ b/tests/imgPPM.test
@@ -6,11 +6,12 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
-eval image delete [image names]
+imageInit
# Note that we do not use [tcltest::makeFile] because it is
# only suitable for text files
@@ -21,145 +22,150 @@ proc put {file data} {
close $f
}
-test imgPPM-1.1 {FileReadPPM procedure} {
+test imgPPM-1.1 {FileReadPPM procedure} -body {
put test.ppm "P6\n0 256\n255\nabcdef"
- list [catch {image create photo p1 -file test.ppm} msg] $msg
-} {1 {PPM image file "test.ppm" has dimension(s) <= 0}}
-test imgPPM-1.2 {FileReadPPM procedure} {
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {PPM image file "test.ppm" has dimension(s) <= 0}
+test imgPPM-1.2 {FileReadPPM procedure} -body {
put test.ppm "P6\n-2 256\n255\nabcdef"
- list [catch {image create photo p1 -file test.ppm} msg] $msg
-} {1 {PPM image file "test.ppm" has dimension(s) <= 0}}
-test imgPPM-1.3 {FileReadPPM procedure} {
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {PPM image file "test.ppm" has dimension(s) <= 0}
+test imgPPM-1.3 {FileReadPPM procedure} -body {
put test.ppm "P6\n10 0\n255\nabcdef"
- list [catch {image create photo p1 -file test.ppm} msg] $msg
-} {1 {PPM image file "test.ppm" has dimension(s) <= 0}}
-test imgPPM-1.4 {FileReadPPM procedure} {
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {PPM image file "test.ppm" has dimension(s) <= 0}
+test imgPPM-1.4 {FileReadPPM procedure} -body {
put test.ppm "P6\n10 -2\n255\nabcdef"
- list [catch {image create photo p1 -file test.ppm} msg] $msg
-} {1 {PPM image file "test.ppm" has dimension(s) <= 0}}
-test imgPPM-1.5 {FileReadPPM procedure} {
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {PPM image file "test.ppm" has dimension(s) <= 0}
+test imgPPM-1.5 {FileReadPPM procedure} -body {
put test.ppm "P6\n10 20\n256\nabcdef"
- list [catch {image create photo p1 -file test.ppm} msg] $msg
-} {1 {PPM image file "test.ppm" has bad maximum intensity value 256}}
-test imgPPM-1.6 {FileReadPPM procedure} {
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {PPM image file "test.ppm" has bad maximum intensity value 256}
+test imgPPM-1.6 {FileReadPPM procedure} -body {
put test.ppm "P6\n10 20\n0\nabcdef"
- list [catch {image create photo p1 -file test.ppm} msg] $msg
-} {1 {PPM image file "test.ppm" has bad maximum intensity value 0}}
-test imgPPM-1.7 {FileReadPPM procedure} {
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {PPM image file "test.ppm" has bad maximum intensity value 0}
+test imgPPM-1.7 {FileReadPPM procedure} -body {
put test.ppm "P6\n10 10\n255\nabcdef"
- list [catch {image create photo p1 -file test.ppm} msg] $msg
-} {1 {error reading PPM image file "test.ppm": not enough data}}
-test imgPPM-1.8 {FileReadPPM procedure} {
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {error reading PPM image file "test.ppm": not enough data}
+test imgPPM-1.8 {FileReadPPM procedure} -body {
put test.ppm "P6\n5 4\n255\n01234567890123456789012345678901234567890123456789012345678"
- list [catch {image create photo p1 -file test.ppm} msg] $msg
-} {1 {error reading PPM image file "test.ppm": not enough data}}
-test imgPPM-1.9 {FileReadPPM procedure} {
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {error reading PPM image file "test.ppm": not enough data}
+test imgPPM-1.9 {FileReadPPM procedure} -body {
put test.ppm "P6\n5 4\n150\n012345678901234567890123456789012345678901234567890123456789"
- list [catch {image create photo p1 -file test.ppm} msg] $msg \
- [image width p1] [image height p1]
-} {0 p1 5 4}
+ list [image create photo p1 -file test.ppm] \
+ [image width p1] [image height p1]
+} -returnCodes ok -result {p1 5 4}
-catch {image delete p1}
-put test.ppm "P6\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
-image create photo p1 -file test.ppm
-test imgPPM-2.1 {FileWritePPM procedure} {
+
+test imgPPM-2.1 {FileWritePPM procedure} -setup {
+ catch {image delete p1}
+} -body {
+ put test.ppm "P6\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
+ image create photo p1 -file test.ppm
list [catch {p1 write not_a_dir/bar/baz/gorp} msg] [string tolower $msg] \
- [string tolower $errorCode]
-} {1 {couldn't open "not_a_dir/bar/baz/gorp": no such file or directory} {posix enoent {no such file or directory}}}
-test imgPPM-2.2 {FileWritePPM procedure} {
+ [string tolower $errorCode]
+} -cleanup {
+ image delete p1
+} -result {1 {couldn't open "not_a_dir/bar/baz/gorp": no such file or directory} {posix enoent {no such file or directory}}}
+
+test imgPPM-2.2 {FileWritePPM procedure} -setup {
+ catch {image delete p1}
catch {unset data}
+} -body {
+ put test.ppm "P6\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
+ image create photo p1 -file test.ppm
p1 write -format ppm test.ppm
set fd [open test.ppm]
set data [read $fd]
close $fd
set data
-} {P6
+} -cleanup {
+ image delete p1
+} -result {P6
5 4
255
012345678901234567890123456789012345678901234567890123456789}
-test imgPPM-3.1 {ReadPPMFileHeader procedure} {
- catch {image delete p1}
+
+test imgPPM-3.1 {ReadPPMFileHeader procedure} -body {
put test.ppm "# \n#\n#\nP6\n#\n##\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
- list [catch {image create photo p1 -file test.ppm} msg] $msg
-} {0 p1}
-test imgPPM-3.2 {ReadPPMFileHeader procedure} {
- catch {image delete p1}
+ image create photo p1 -file test.ppm
+} -cleanup {
+ image delete p1
+} -returnCodes ok -result p1
+test imgPPM-3.2 {ReadPPMFileHeader procedure} -body {
put test.ppm "P6\n5\n 4 255\n012345678901234567890123456789012345678901234567890123456789"
- list [catch {image create photo p1 -file test.ppm} msg] $msg
-} {0 p1}
-test imgPPM-3.3 {ReadPPMFileHeader procedure} {
- catch {image delete p1}
+ image create photo p1 -file test.ppm
+} -cleanup {
+ image delete p1
+} -returnCodes ok -result p1
+test imgPPM-3.3 {ReadPPMFileHeader procedure} -body {
put test.ppm "P6\n# asdfasdf\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
- list [catch {image create photo p1 -file test.ppm} msg] $msg
-} {0 p1}
-test imgPPM-3.4 {ReadPPMFileHeader procedure} {
- catch {image delete p1}
+ image create photo p1 -file test.ppm
+} -cleanup {
+ image delete p1
+} -returnCodes ok -result p1
+test imgPPM-3.4 {ReadPPMFileHeader procedure} -body {
put test.ppm "P6 \n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
- list [catch {image create photo p1 -file test.ppm} msg] $msg
-} {0 p1}
-test imgPPM-3.5 {ReadPPMFileHeader procedure} {
- catch {image delete p1}
+ image create photo p1 -file test.ppm
+} -cleanup {
+ image delete p1
+} -returnCodes ok -result p1
+test imgPPM-3.5 {ReadPPMFileHeader procedure} -body {
put test.ppm "P5\n5 4\n255\n01234567890123456789"
- list [catch {image create photo p1 -file test.ppm} msg] $msg
-} {0 p1}
-test imgPPM-3.6 {ReadPPMFileHeader procedure} {
- catch {image delete p1}
+ image create photo p1 -file test.ppm
+} -cleanup {
+ image delete p1
+} -returnCodes ok -result p1
+test imgPPM-3.6 {ReadPPMFileHeader procedure} -body {
put test.ppm "P3\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
- list [catch {image create photo p1 -file test.ppm} msg] $msg
-} {1 {couldn't recognize data in image file "test.ppm"}}
-test imgPPM-3.7 {ReadPPMFileHeader procedure} {
- catch {image delete p1}
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {couldn't recognize data in image file "test.ppm"}
+test imgPPM-3.7 {ReadPPMFileHeader procedure} -body {
put test.ppm "P6x\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
- list [catch {image create photo p1 -file test.ppm} msg] $msg
-} {1 {couldn't recognize data in image file "test.ppm"}}
-test imgPPM-3.8 {ReadPPMFileHeader procedure} {
- catch {image delete p1}
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {couldn't recognize data in image file "test.ppm"}
+test imgPPM-3.8 {ReadPPMFileHeader procedure} -body {
put test.ppm "P6\nxy5 4\n255\n012345678901234567890123456789012345678901234567890123456789"
- list [catch {image create photo p1 -file test.ppm} msg] $msg
-} {1 {couldn't recognize data in image file "test.ppm"}}
-test imgPPM-3.9 {ReadPPMFileHeader procedure} {
- catch {image delete p1}
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {couldn't recognize data in image file "test.ppm"}
+test imgPPM-3.9 {ReadPPMFileHeader procedure} -body {
put test.ppm "P6\n5\n255\n!012345678901234567890123456789012345678901234567890123456789"
- list [catch {image create photo p1 -file test.ppm} msg] $msg
-} {1 {couldn't recognize data in image file "test.ppm"}}
-test imgPPM-3.10 {ReadPPMFileHeader procedure} {
- catch {image delete p1}
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {couldn't recognize data in image file "test.ppm"}
+test imgPPM-3.10 {ReadPPMFileHeader procedure} -body {
put test.ppm "P6\n5 4\nzz255\n012345678901234567890123456789012345678901234567890123456789"
- list [catch {image create photo p1 -file test.ppm} msg] $msg
-} {1 {couldn't recognize data in image file "test.ppm"}}
-test imgPPM-3.11 {ReadPPMFileHeader procedure, empty file} {
- catch {image delete p1}
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {couldn't recognize data in image file "test.ppm"}
+test imgPPM-3.11 {ReadPPMFileHeader procedure, empty file} -body {
put test.ppm " "
- list [catch {image create photo p1 -file test.ppm} msg] $msg
-} {1 {couldn't recognize data in image file "test.ppm"}}
-test imgPPM-3.12 {ReadPPMFileHeader procedure, file ends too soon} {
- catch {image delete p1}
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {couldn't recognize data in image file "test.ppm"}
+test imgPPM-3.12 {ReadPPMFileHeader procedure, file ends too soon} -body {
put test.ppm "P6\n566"
- list [catch {image create photo p1 -file test.ppm} msg] $msg
-} {1 {couldn't recognize data in image file "test.ppm"}}
-test imgPPM-3.13 {ReadPPMFileHeader procedure, file ends too soon} {
- catch {image delete p1}
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {couldn't recognize data in image file "test.ppm"}
+test imgPPM-3.13 {ReadPPMFileHeader procedure, file ends too soon} -body {
put test.ppm "P6\n566\n#asdf"
- list [catch {image create photo p1 -file test.ppm} msg] $msg
-} {1 {couldn't recognize data in image file "test.ppm"}}
+ image create photo p1 -file test.ppm
+} -returnCodes error -result {couldn't recognize data in image file "test.ppm"}
-test imgPPM-4.1 {StringReadPPM procedure, data too short [Bug 1822391]} \
- -setup {
- image create photo I -width 1103 -height 997
- } \
- -cleanup {
- image delete I
- } \
- -body {
- I put "P5\n1103 997\n255\n"
- } \
- -returnCodes error \
- -result {truncated PPM data}
-eval image delete [image names]
+test imgPPM-4.1 {StringReadPPM procedure, data too short [Bug 1822391]} -body {
+ image create photo I -width 1103 -height 997
+ I put "P5\n1103 997\n255\n"
+} -cleanup {
+ image delete I
+} -returnCodes error -result {truncated PPM data}
+
+imageFinish
# cleanup
catch {file delete test.ppm}
cleanupTests
return
+
diff --git a/tests/imgPhoto.test b/tests/imgPhoto.test
index d4118b0..e85f512 100644
--- a/tests/imgPhoto.test
+++ b/tests/imgPhoto.test
@@ -1,486 +1,867 @@
-# This file is a Tcl script to test out the "photo" image type and the
-# other procedures in the file tkImgPhoto.c. It is organized in the
-# standard fashion for Tcl tests.
+# This file is a Tcl script to test out the "photo" image type and the other
+# procedures in the file tkImgPhoto.c. It is organized in the standard fashion
+# for Tcl tests.
#
# Copyright (c) 1994 The Australian National University
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 2002-2008 Donal K. Fellows
# All rights reserved.
#
# Author: Paul Mackerras (paulus@cs.anu.edu.au)
-package require tcltest 2.1
-eval tcltest::configure $argv
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::configure {*}$argv
tcltest::loadTestedCommands
-eval image delete [image names]
-
-canvas .c
-pack .c
-update
+# Used for 4.65 - 4.73 tests
+# Now for some heftier testing, checking that setting and resetting of pixels'
+# transparency status doesn't "leak" with any one-off errors.
+proc foreachPixel {img xVar yVar script} {
+ upvar 1 $xVar x $yVar y
+ set width [image width $img]
+ set height [image height $img]
+ for {set x 0} {$x<$width} {incr x} {
+ for {set y 0} {$y<$height} {incr y} {
+ uplevel 1 $script
+ }
+ }
+}
+proc checkImgTrans {img} {
+ set result {}
+ foreachPixel $img x y {
+ if {[$img transparency get $x $y]} {
+ lappend result $x,$y
+ }
+ }
+ return $result
+}
+proc checkImgTransLoop {img script1 script2} {
+ set result {}
+ foreachPixel $img x y {
+ eval $script1
+ lappend result {*}[checkImgTrans $img]
+ append result :
+ eval $script2
+ lappend result {*}[checkImgTrans $img]
+ append result .
+ }
+ return $result
+}
+imageInit
set README [makeFile {
-README -- Tk test suite design document.
+ README -- Tk test suite design document.
} README-imgPhoto]
# find the teapot.ppm file for use in these tests
set teapotPhotoFile [file join [file dirname [info script]] teapot.ppm]
testConstraint hasTeapotPhoto [file exists $teapotPhotoFile]
-test imgPhoto-1.1 {options for photo images} {
- image create photo p1 -width 79 -height 83
- list [lindex [p1 configure -width] 4] [lindex [p1 configure -height] 4] \
- [image width p1] [image height p1]
-} {79 83 79 83}
-test imgPhoto-1.2 {options for photo images} {
- list [catch {image create photo p1 -file no.such.file} err] \
+# ----------------------------------------------------------------------
+
+test imgPhoto-1.1 {options for photo images} -body {
+ image create photo photo1 -width 79 -height 83
+ list [photo1 cget -width] [photo1 cget -height] \
+ [image width photo1] [image height photo1]
+} -cleanup {
+ image delete photo1
+} -result {79 83 79 83}
+test imgPhoto-1.2 {options for photo images} -body {
+ list [catch {image create photo photo1 -file no.such.file} err] \
[string tolower $err]
-} {1 {couldn't open "no.such.file": no such file or directory}}
-test imgPhoto-1.3 {options for photo images} hasTeapotPhoto {
- list [catch {image create photo p1 -file $teapotPhotoFile \
- -format no.such.format} err] $err
-} {1 {image file format "no.such.format" is not supported}}
-test imgPhoto-1.4 {options for photo images} hasTeapotPhoto {
- image create photo p1 -file $teapotPhotoFile
- list [image width p1] [image height p1]
-} {256 256}
-test imgPhoto-1.5 {options for photo images} hasTeapotPhoto {
- image create photo p1 -file $teapotPhotoFile \
- -format ppm -width 79 -height 83
- list [image width p1] [image height p1] \
- [lindex [p1 configure -file] 4] [lindex [p1 configure -format] 4]
-} [list 79 83 $teapotPhotoFile ppm]
-test imgPhoto-1.6 {options for photo images} {
- image create photo p1 -palette 2/2/2 -gamma 2.2
- list [format %.1f [lindex [p1 configure -gamma] 4]] \
- [lindex [p1 configure -palette] 4]
-} {2.2 2/2/2}
-test imgPhoto-1.7 {options for photo images} {
- list [catch {image create photo p1 -file $README} err] $err
-} [subst {1 {couldn't recognize data in image file "$README"}}]
-test imgPhoto-1.8 {options for photo images} {
- list [catch {image create photo -blah blah} err] $err
-} {1 {unknown option "-blah"}}
-test imgPhoto-1.9 {options for photo images - error case} {
- list [catch {image create photo -format} err] $err
-} {1 {value for "-format" missing}}
-test imgPhoto-1.10 {options for photo images - error case} {
- list [catch {image create photo -data} err] $err
-} {1 {value for "-data" missing}}
-test imgPhoto-1.11 {options for photo images - error case} {
- list [catch {image create photo p1 -format} err] $err
-} {1 {value for "-format" missing}}
+} -result {1 {couldn't open "no.such.file": no such file or directory}}
+test imgPhoto-1.3 {options for photo images} -constraints hasTeapotPhoto -body {
+ image create photo photo1 -file $teapotPhotoFile -format no.such.format
+} -returnCodes error -result {image file format "no.such.format" is not supported}
+test imgPhoto-1.4 {options for photo images} -constraints hasTeapotPhoto -body {
+ image create photo photo1 -file $teapotPhotoFile
+ list [image width photo1] [image height photo1]
+} -cleanup {
+ image delete photo1
+} -result {256 256}
+test imgPhoto-1.5 {options for photo images} -constraints hasTeapotPhoto -body {
+ image create photo photo1 -file $teapotPhotoFile \
+ -format ppm -width 79 -height 83
+ list [image width photo1] [image height photo1] [photo1 cget -file] [photo1 cget -format]
+} -cleanup {
+ image delete photo1
+} -result [list 79 83 $teapotPhotoFile ppm]
+test imgPhoto-1.6 {options for photo images} -body {
+ image create photo photo1 -palette 2/2/2 -gamma 2.2
+ list [format %.1f [photo1 cget -gamma]] [photo1 cget -palette]
+} -cleanup {
+ image delete photo1
+} -result {2.2 2/2/2}
+test imgPhoto-1.7 {options for photo images} -returnCodes error -body {
+ image create photo photo1 -file $README
+} -result [subst {couldn't recognize data in image file "$README"}]
+test imgPhoto-1.8 {options for photo images} -body {
+ image create photo -blah blah
+} -returnCodes error -result {unknown option "-blah"}
+test imgPhoto-1.9 {options for photo images - error case} -body {
+ image create photo -format
+} -returnCodes error -result {value for "-format" missing}
+test imgPhoto-1.10 {options for photo images - error case} -body {
+ image create photo -data
+} -returnCodes error -result {value for "-data" missing}
+test imgPhoto-1.11 {options for photo images - error case} -body {
+ image create photo photo1 -format
+} -returnCodes error -result {value for "-format" missing}
-test imgPhoto-2.1 {ImgPhotoCreate procedure} {
- eval image delete [image names]
+test imgPhoto-2.1 {ImgPhotoCreate procedure} -setup {
+ imageCleanup
+} -body {
catch {image create photo -blah blah}
- image names
-} {}
-test imgPhoto-2.2 {ImgPhotoCreate procedure} {
- eval image delete [image names]
+ imageNames
+} -result {}
+test imgPhoto-2.2 {ImgPhotoCreate procedure} -setup {
+ imageCleanup
+} -body {
image create photo image1
- list [info commands image1] [image names] \
- [image width image1] [image height image1]
-} {image1 image1 0 0}
+ list [info commands image1] [imageNames] \
+ [image width image1] [image height image1]
+} -cleanup {
+ image delete image1
+} -result {image1 image1 0 0}
# test imgPhoto-2.3 {ImgPhotoCreate procedure: creation failure} {
-# image create photo p1
-# image create photo p2 -width 10 -height 10
-# catch {image create photo p2 -file bogus.img} msg
-# p1 copy p2
+# image create photo photo1
+# image create photo photo2 -width 10 -height 10
+# catch {image create photo photo2 -file bogus.img} msg
+# photo1 copy photo2
# set msg
# } {couldn't open "bogus.img": no such file or directory}
-test imgPhoto-3.1 {ImgPhotoConfigureMaster procedure} hasTeapotPhoto {
- image create photo p1 -file $teapotPhotoFile
- p1 configure -file $teapotPhotoFile
-} {}
-test imgPhoto-3.2 {ImgPhotoConfigureMaster procedure} hasTeapotPhoto {
- image create photo p1 -file $teapotPhotoFile
- list [catch {p1 configure -file bogus} err] [string tolower $err] \
- [image width p1] [image height p1]
-} {1 {couldn't open "bogus": no such file or directory} 256 256}
-test imgPhoto-3.3 {ImgPhotoConfigureMaster procedure} hasTeapotPhoto {
- image create photo p1
- .c create image 10 10 -image p1 -tags p1.1 -anchor nw
- .c create image 300 10 -image p1 -tags p1.2 -anchor nw
+test imgPhoto-3.1 {ImgPhotoConfigureMaster procedure} -constraints {
+ hasTeapotPhoto
+} -body {
+ image create photo photo1 -file $teapotPhotoFile
+ photo1 configure -file $teapotPhotoFile
+} -cleanup {
+ image delete photo1
+} -result {}
+test imgPhoto-3.2 {ImgPhotoConfigureMaster procedure} -constraints {
+ hasTeapotPhoto
+} -body {
+ image create photo photo1 -file $teapotPhotoFile
+ list [catch {photo1 configure -file bogus} err] [string tolower $err] \
+ [image width photo1] [image height photo1]
+} -cleanup {
+ image delete photo1
+} -result {1 {couldn't open "bogus": no such file or directory} 256 256}
+test imgPhoto-3.3 {ImgPhotoConfigureMaster procedure} -constraints {
+ hasTeapotPhoto
+} -setup {
+ destroy .c
+ pack [canvas .c]
update
- p1 configure -file $teapotPhotoFile
+} -body {
+ image create photo photo1
+ .c create image 10 10 -image photo1 -tags photo1.1 -anchor nw
+ .c create image 300 10 -image photo1 -tags photo1.2 -anchor nw
update
- list [image width p1] [image height p1] [.c bbox p1.1] [.c bbox p1.2]
-} {256 256 {10 10 266 266} {300 10 556 266}}
-
-eval image delete [image names]
-image create photo p1
-.c create image 10 10 -image p1
-update
+ photo1 configure -file $teapotPhotoFile
+ update
+ list [image width photo1] [image height photo1] [.c bbox photo1.1] [.c bbox photo1.2]
+} -cleanup {
+ destroy .c
+ image delete photo1
+} -result {256 256 {10 10 266 266} {300 10 556 266}}
-test imgPhoto-4.1 {ImgPhotoCmd procedure} {
- list [catch {p1} err] $err
-} {1 {wrong # args: should be "p1 option ?arg arg ...?"}}
-test imgPhoto-4.2 {ImgPhotoCmd procedure} {
- list [catch {p1 blah} err] $err
-} {1 {bad option "blah": must be blank, cget, configure, copy, data, get, put, read, redither, transparency, or write}}
-test imgPhoto-4.3 {ImgPhotoCmd procedure: blank option} {
- p1 blank
- list [catch {p1 blank x} err] $err
-} {1 {wrong # args: should be "p1 blank"}}
-test imgPhoto-4.4 {ImgPhotoCmd procedure: cget option} {
- list [catch {p1 cget} msg] $msg
-} {1 {wrong # args: should be "p1 cget option"}}
-test imgPhoto-4.5 {ImgPhotoCmd procedure: cget option} {
- image create photo p2 -width 25 -height 30
- list [p2 cget -width] [p2 cget -height]
-} {25 30}
-test imgPhoto-4.6 {ImgPhotoCmd procedure: configure option} {
- llength [p1 configure]
-} {7}
-test imgPhoto-4.7 {ImgPhotoCmd procedure: configure option} {
- p1 conf -palette 3/4/2
- p1 configure -palette
-} {-palette {} {} {} 3/4/2}
-test imgPhoto-4.8 {ImgPhotoCmd procedure: configure option} {
- list [catch {p1 configure -blah} msg] $msg
-} {1 {unknown option "-blah"}}
-test imgPhoto-4.9 {ImgPhotoCmd procedure: configure option} {
- list [catch {p1 configure -palette {} -gamma} msg] $msg
-} {1 {value for "-gamma" missing}}
-test imgPhoto-4.10 {ImgPhotoCmd procedure: copy option} hasTeapotPhoto {
- image create photo p2 -file $teapotPhotoFile
- p1 configure -width 0 -height 0 -palette {} -gamma 1
- p1 copy p2
- list [image width p1] [image height p1] [p1 get 100 100]
-} {256 256 {169 117 90}}
-test imgPhoto-4.11 {ImgPhotoCmd procedure: copy option} {
- list [catch {p1 copy} msg] $msg
-} {1 {wrong # args: should be "p1 copy source-image ?-compositingrule rule? ?-from x1 y1 x2 y2? ?-to x1 y1 x2 y2? ?-zoom x y? ?-subsample x y?"}}
-test imgPhoto-4.12 {ImgPhotoCmd procedure: copy option} {
- list [catch {p1 copy blah} msg] $msg
-} {1 {image "blah" doesn't exist or is not a photo image}}
-test imgPhoto-4.13 {ImgPhotoCmd procedure: copy option} {
- list [catch {p1 copy p2 -blah} msg] $msg
-} {1 {unrecognized option "-blah": must be -compositingrule, -from, -shrink, -subsample, -to, or -zoom}}
-test imgPhoto-4.14 {ImgPhotoCmd procedure: copy option} {
- list [catch {p1 copy p2 -from -to} msg] $msg
-} {1 {the "-from" option requires one to four integer values}}
-test imgPhoto-4.15 {ImgPhotoCmd procedure: copy option} {
- p1 copy p2
- p1 copy p2 -from 0 70 60 120 -shrink
- list [image width p1] [image height p1] [p1 get 20 10]
-} {60 50 {215 154 120}}
-test imgPhoto-4.16 {ImgPhotoCmd procedure: copy option} {
- p1 copy p2 -from 60 120 0 70 -to 20 50
- list [image width p1] [image height p1] [p1 get 40 80]
-} {80 100 {19 92 192}}
-test imgPhoto-4.17 {ImgPhotoCmd procedure: copy option} {
- p1 copy p2 -from 0 120 60 70 -to 0 0 100 100
- list [image width p1] [image height p1] [p1 get 80 60]
-} {100 100 {215 154 120}}
-test imgPhoto-4.18 {ImgPhotoCmd procedure: copy option} {
- p1 copy p2 -from 60 70 0 120 -zoom 2
- list [image width p1] [image height p1] [p1 get 100 50]
-} {120 100 {169 99 47}}
-test imgPhoto-4.19 {ImgPhotoCmd procedure: copy option} {
- p1 copy p2 -from 0 70 60 120
- list [image width p1] [image height p1] [p1 get 100 50]
-} {120 100 {169 99 47}}
-test imgPhoto-4.20 {ImgPhotoCmd procedure: copy option} {
- p1 copy p2 -from 20 20 200 180 -subsample 2 -shrink
- list [image width p1] [image height p1] [p1 get 50 30]
-} {90 80 {207 146 112}}
-test imgPhoto-4.21 {ImgPhotoCmd procedure: copy option} {
- p1 copy p2
- set result [list [image width p1] [image height p1]]
- p1 conf -width 49 -height 51
- lappend result [image width p1] [image height p1]
- p1 copy p2
- lappend result [image width p1] [image height p1]
- p1 copy p2 -from 0 0 10 10 -shrink
- lappend result [image width p1] [image height p1]
- p1 conf -width 0
- p1 copy p2 -from 0 0 10 10 -shrink
- lappend result [image width p1] [image height p1]
- p1 conf -height 0
- p1 copy p2 -from 0 0 10 10 -shrink
- lappend result [image width p1] [image height p1]
-} {256 256 49 51 49 51 49 51 10 51 10 10}
-test imgPhoto-4.22 {ImgPhotoCmd procedure: get option} hasTeapotPhoto {
- p1 read $teapotPhotoFile
- list [p1 get 100 100] [p1 get 150 100] [p1 get 100 150]
-} {{169 117 90} {172 115 84} {35 35 35}}
-test imgPhoto-4.23 {ImgPhotoCmd procedure: get option} {
- list [catch {p1 get 256 0} err] $err
-} {1 {p1 get: coordinates out of range}}
-test imgPhoto-4.24 {ImgPhotoCmd procedure: get option} {
- list [catch {p1 get 0 -1} err] $err
-} {1 {p1 get: coordinates out of range}}
-test imgPhoto-4.25 {ImgPhotoCmd procedure: get option} {
- list [catch {p1 get} err] $err
-} {1 {wrong # args: should be "p1 get x y"}}
-test imgPhoto-4.26 {ImgPhotoCmd procedure: put option} {
- list [catch {p1 put} err] $err
-} {1 {wrong # args: should be "p1 put data ?options?"}}
-test imgPhoto-4.27 {ImgPhotoCmd procedure: put option} {
- list [catch {p1 put {{white} {white white}}} err] $err
-} {1 {all elements of color list must have the same number of elements}}
-test imgPhoto-4.28 {ImgPhotoCmd procedure: put option} {
- list [catch {p1 put {{blahgle}}} err] $err
-} {1 {can't parse color "blahgle"}}
-test imgPhoto-4.29 {ImgPhotoCmd procedure: put option} {
- p1 put -to 10 10 20 20 {{white}}
- p1 get 19 19
-} {255 255 255}
-test imgPhoto-4.30 {ImgPhotoCmd procedure: read option} {
- list [catch {p1 read} err] $err
-} {1 {wrong # args: should be "p1 read fileName ?options?"}}
-test imgPhoto-4.31 {ImgPhotoCmd procedure: read option} hasTeapotPhoto {
- list [catch {p1 read $teapotPhotoFile -zoom 2} err] $err
-} {1 {unrecognized option "-zoom": must be -format, -from, -shrink, or -to}}
-test imgPhoto-4.32 {ImgPhotoCmd procedure: read option} {
- list [catch {p1 read bogus} err] [string tolower $err]
-} {1 {couldn't open "bogus": no such file or directory}}
-test imgPhoto-4.33 {ImgPhotoCmd procedure: read option} hasTeapotPhoto {
- list [catch {p1 read $teapotPhotoFile -format bogus} err] $err
-} {1 {image file format "bogus" is not supported}}
-test imgPhoto-4.34 {ImgPhotoCmd procedure: read option} {
- list [catch {p1 read $README} err] $err
-} [subst {1 {couldn't recognize data in image file "$README"}}]
-test imgPhoto-4.35 {ImgPhotoCmd procedure: read option} hasTeapotPhoto {
- p1 read $teapotPhotoFile
- list [image width p1] [image height p1] [p1 get 120 120]
-} {256 256 {161 109 82}}
-test imgPhoto-4.36 {ImgPhotoCmd procedure: read option} hasTeapotPhoto {
- p1 read $teapotPhotoFile -from 0 70 60 120 -to 10 10 -shrink
- list [image width p1] [image height p1] [p1 get 29 19]
-} {70 60 {244 180 144}}
-test imgPhoto-4.37 {ImgPhotoCmd procedure: redither option} {
- p1 redither
- list [catch {p1 redither x} err] $err
-} {1 {wrong # args: should be "p1 redither"}}
-test imgPhoto-4.38 {ImgPhotoCmd procedure: write option} {
- list [catch {p1 write} err] $err
-} {1 {wrong # args: should be "p1 write fileName ?options?"}}
-test imgPhoto-4.39 {ImgPhotoCmd procedure: write option} {
- list [catch {p1 write teapot.tmp -format bogus} err] $err
-} {1 {image file format "bogus" is unknown}}
-eval image delete [image names]
-image create photo p1
-test imgPhoto-4.40 {ImgPhotoCmd procedure: transparency option} {
- list [catch {p1 transparency} err] $err
-} {1 {wrong # args: should be "p1 transparency option ?arg arg ...?"}}
-test imgPhoto-4.41 {ImgPhotoCmd procedure: transparency get option} {
- list [catch {p1 transparency get} err] $err
-} {1 {wrong # args: should be "p1 transparency get x y"}}
-test imgPhoto-4.42 {ImgPhotoCmd procedure: transparency get option} {
- list [catch {p1 transparency get 0} err] $err
-} {1 {wrong # args: should be "p1 transparency get x y"}}
-test imgPhoto-4.43 {ImgPhotoCmd procedure: transparency get option} {
- list [catch {p1 transparency get 0 0 0} err] $err
-} {1 {wrong # args: should be "p1 transparency get x y"}}
-test imgPhoto-4.44 {ImgPhotoCmd procedure: transparency get option} {
- list [catch {p1 transparency get bogus 0} err] $err
-} {1 {expected integer but got "bogus"}}
-test imgPhoto-4.45 {ImgPhotoCmd procedure: transparency get option} {
- list [catch {p1 transparency get 0 bogus} err] $err
-} {1 {expected integer but got "bogus"}}
-test imgPhoto-4.46 {ImgPhotoCmd procedure: transparency get option} {
- p1 put white
- p1 transparency get 0 0
-} 0
-test imgPhoto-4.47 {ImgPhotoCmd procedure: transparency get option} {
- list [catch {p1 transparency get 1 0} err] $err
-} {1 {p1 transparency get: coordinates out of range}}
-test imgPhoto-4.48 {ImgPhotoCmd procedure: transparency get option} {
- list [catch {p1 transparency get -1 0} err] $err
-} {1 {p1 transparency get: coordinates out of range}}
-test imgPhoto-4.49 {ImgPhotoCmd procedure: transparency get option} {
- list [catch {p1 transparency get 0 1} err] $err
-} {1 {p1 transparency get: coordinates out of range}}
-test imgPhoto-4.50 {ImgPhotoCmd procedure: transparency get option} {
- list [catch {p1 transparency get 0 -1} err] $err
-} {1 {p1 transparency get: coordinates out of range}}
-test imgPhoto-4.51 {ImgPhotoCmd procedure: transparency get option} {
- p1 blank
- p1 transparency get 0 0
-} 1
-test imgPhoto-4.52 {ImgPhotoCmd procedure: transparency set option} {
- list [catch {p1 transparency set} err] $err
-} {1 {wrong # args: should be "p1 transparency set x y boolean"}}
-test imgPhoto-4.53 {ImgPhotoCmd procedure: transparency set option} {
- list [catch {p1 transparency set 0} err] $err
-} {1 {wrong # args: should be "p1 transparency set x y boolean"}}
-test imgPhoto-4.54 {ImgPhotoCmd procedure: transparency set option} {
- list [catch {p1 transparency set 0 0} err] $err
-} {1 {wrong # args: should be "p1 transparency set x y boolean"}}
-test imgPhoto-4.55 {ImgPhotoCmd procedure: transparency set option} {
- list [catch {p1 transparency set 0 0 0 0} err] $err
-} {1 {wrong # args: should be "p1 transparency set x y boolean"}}
-test imgPhoto-4.56 {ImgPhotoCmd procedure: transparency set option} {
- list [catch {p1 transparency set bogus 0 0} err] $err
-} {1 {expected integer but got "bogus"}}
-test imgPhoto-4.57 {ImgPhotoCmd procedure: transparency set option} {
- list [catch {p1 transparency set 0 bogus 0} err] $err
-} {1 {expected integer but got "bogus"}}
-test imgPhoto-4.58 {ImgPhotoCmd procedure: transparency set option} {
- list [catch {p1 transparency set 0 0 bogus} err] $err
-} {1 {expected boolean value but got "bogus"}}
-test imgPhoto-4.59 {ImgPhotoCmd procedure: transparency set option} {
- list [catch {p1 transparency set 1 0 0} err] $err
-} {1 {p1 transparency set: coordinates out of range}}
-test imgPhoto-4.60 {ImgPhotoCmd procedure: transparency set option} {
- list [catch {p1 transparency set -1 0 0} err] $err
-} {1 {p1 transparency set: coordinates out of range}}
-test imgPhoto-4.61 {ImgPhotoCmd procedure: transparency set option} {
- list [catch {p1 transparency set 0 1 0} err] $err
-} {1 {p1 transparency set: coordinates out of range}}
-test imgPhoto-4.62 {ImgPhotoCmd procedure: transparency set option} {
- list [catch {p1 transparency set 0 -1 0} err] $err
-} {1 {p1 transparency set: coordinates out of range}}
-test imgPhoto-4.63 {ImgPhotoCmd procedure: transparency set option} {
- p1 transparency set 0 0 false
- p1 transparency get 0 0
-} 0
-test imgPhoto-4.64 {ImgPhotoCmd procedure: transparency set option} {
- p1 transparency set 0 0 true
- p1 transparency get 0 0
-} 1
-# Now for some heftier testing, checking that setting and resetting of
-# pixels' transparency status doesn't "leak" with any one-off errors.
-proc checkImgTrans {img width height} {
- set result {}
- for {set x 0} {$x<$width} {incr x} {
- for {set y 0} {$y<$height} {incr y} {
- if {[$img transparency get $x $y]} {
- lappend result $x $y
- }
- }
- }
- return $result
-}
-test imgPhoto-4.65 {ImgPhotoCmd procedure: transparency get option} {
- p1 put white -to 0 0 3 3
- checkImgTrans p1 3 3
-} {}
-test imgPhoto-4.66 {ImgPhotoCmd procedure: transparency get option} {
- p1 blank
- checkImgTrans p1 3 3
-} {0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2}
-proc checkImgTransLoopSetReset {img width height} {
- set result {}
- for {set x 0} {$x<$width} {incr x} {
- for {set y 0} {$y<$height} {incr y} {
- $img put white -to 0 0 3 3
- $img transparency set $x $y 1
- set result [concat $result [checkImgTrans $img $width $height]]
- lappend result ,
- $img transparency set $x $y 0
- set result [concat $result [checkImgTrans $img $width $height]]
- lappend result .
- }
+test imgPhoto-4.1 {ImgPhotoCmd procedure} -setup {
+ image create photo photo1
+} -body {
+ photo1
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {wrong # args: should be "photo1 option ?arg ...?"}
+test imgPhoto-4.2 {ImgPhotoCmd procedure} -setup {
+ image create photo photo1
+} -body {
+ photo1 blah
+} -returnCodes error -cleanup {
+ image delete photo1
+} -match glob -result {bad option "blah": must be *}
+test imgPhoto-4.3 {ImgPhotoCmd procedure: blank option} -setup {
+ image create photo photo1
+} -body {
+ photo1 blank
+ photo1 blank x
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {wrong # args: should be "photo1 blank"}
+test imgPhoto-4.4 {ImgPhotoCmd procedure: cget option} -setup {
+ image create photo photo1
+} -body {
+ photo1 cget
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {wrong # args: should be "photo1 cget option"}
+test imgPhoto-4.5 {ImgPhotoCmd procedure: cget option} -setup {
+ image create photo photo2 -width 25 -height 30
+} -body {
+ list [photo2 cget -width] [photo2 cget -height]
+} -cleanup {
+ image delete photo2
+} -result {25 30}
+test imgPhoto-4.6 {ImgPhotoCmd procedure: configure option} -setup {
+ image create photo photo1
+} -body {
+ llength [photo1 configure]
+} -cleanup {
+ image delete photo1
+} -result 7
+test imgPhoto-4.7 {ImgPhotoCmd procedure: configure option} -setup {
+ image create photo photo1
+} -body {
+ photo1 conf -palette 3/4/2
+ photo1 configure -palette
+} -cleanup {
+ image delete photo1
+} -result {-palette {} {} {} 3/4/2}
+test imgPhoto-4.8 {ImgPhotoCmd procedure: configure option} -setup {
+ image create photo photo1
+} -body {
+ photo1 configure -blah
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {unknown option "-blah"}
+test imgPhoto-4.9 {ImgPhotoCmd procedure: configure option} -setup {
+ image create photo photo1
+} -body {
+ photo1 configure -palette {} -gamma
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {value for "-gamma" missing}
+test imgPhoto-4.10 {ImgPhotoCmd procedure: copy option} -constraints {
+ hasTeapotPhoto
+} -setup {
+ image create photo photo1
+ image create photo photo2 -width 25 -height 30
+} -body {
+ image create photo photo2 -file $teapotPhotoFile
+ photo1 configure -width 0 -height 0 -palette {} -gamma 1
+ photo1 copy photo2
+ list [image width photo1] [image height photo1] [photo1 get 100 100]
+} -cleanup {
+ image delete photo1 photo2
+} -result {256 256 {169 117 90}}
+test imgPhoto-4.11 {ImgPhotoCmd procedure: copy option} -setup {
+ image create photo photo1
+} -body {
+ photo1 copy
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {wrong # args: should be "photo1 copy source-image ?-compositingrule rule? ?-from x1 y1 x2 y2? ?-to x1 y1 x2 y2? ?-zoom x y? ?-subsample x y?"}
+test imgPhoto-4.12 {ImgPhotoCmd procedure: copy option} -setup {
+ image create photo photo1
+} -body {
+ photo1 copy blah
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {image "blah" doesn't exist or is not a photo image}
+test imgPhoto-4.13 {ImgPhotoCmd procedure: copy option} -setup {
+ image create photo photo1
+ image create photo photo2
+} -body {
+ photo1 copy photo2 -blah
+} -returnCodes error -cleanup {
+ image delete photo1 photo2
+} -result {unrecognized option "-blah": must be -compositingrule, -from, -shrink, -subsample, -to, or -zoom}
+test imgPhoto-4.14 {ImgPhotoCmd procedure: copy option} -setup {
+ image create photo photo1
+ image create photo photo2
+} -body {
+ photo1 copy photo2 -from -to
+} -returnCodes error -cleanup {
+ image delete photo1 photo2
+} -result {the "-from" option requires one to four integer values}
+test imgPhoto-4.15 {ImgPhotoCmd procedure: copy option} -constraints {
+ hasTeapotPhoto
+} -setup {
+ image create photo photo1
+ image create photo photo2 -file $teapotPhotoFile
+} -body {
+ photo1 copy photo2
+ photo1 copy photo2 -from 0 70 60 120 -shrink
+ list [image width photo1] [image height photo1] [photo1 get 20 10]
+} -cleanup {
+ image delete photo1 photo2
+} -result {60 50 {215 154 120}}
+test imgPhoto-4.16 {ImgPhotoCmd procedure: copy option} -constraints {
+ hasTeapotPhoto
+} -setup {
+ image create photo photo1
+ image create photo photo2 -file $teapotPhotoFile
+} -body {
+ photo1 copy photo2 -from 60 120 0 70 -to 20 50
+ list [image width photo1] [image height photo1] [photo1 get 40 80]
+} -cleanup {
+ image delete photo1 photo2
+} -result {80 100 {19 92 192}}
+test imgPhoto-4.17 {ImgPhotoCmd procedure: copy option} -constraints {
+ hasTeapotPhoto
+} -setup {
+ image create photo photo1
+ image create photo photo2 -file $teapotPhotoFile
+} -body {
+ photo1 copy photo2 -from 0 120 60 70 -to 0 0 100 100
+ list [image width photo1] [image height photo1] [photo1 get 80 60]
+} -cleanup {
+ image delete photo1 photo2
+} -result {100 100 {215 154 120}}
+test imgPhoto-4.18 {ImgPhotoCmd procedure: copy option} -constraints {
+ hasTeapotPhoto
+} -setup {
+ image create photo photo1
+ image create photo photo2 -file $teapotPhotoFile
+} -body {
+ photo1 copy photo2 -from 60 70 0 120 -zoom 2
+ list [image width photo1] [image height photo1] [photo1 get 100 50]
+} -cleanup {
+ image delete photo1 photo2
+} -result {120 100 {169 99 47}}
+test imgPhoto-4.19 {ImgPhotoCmd procedure: copy option} -constraints {
+ hasTeapotPhoto
+} -setup {
+ image create photo photo1
+ image create photo photo2 -file $teapotPhotoFile
+} -body {
+ photo1 copy photo2 -from 0 70 60 120 -zoom 2
+ list [image width photo1] [image height photo1] [photo1 get 100 50]
+} -cleanup {
+ image delete photo1 photo2
+} -result {120 100 {169 99 47}}
+test imgPhoto-4.20 {ImgPhotoCmd procedure: copy option} -constraints {
+ hasTeapotPhoto
+} -setup {
+ image create photo photo1
+ image create photo photo2 -file $teapotPhotoFile
+} -body {
+ photo1 copy photo2 -from 20 20 200 180 -subsample 2 -shrink
+ list [image width photo1] [image height photo1] [photo1 get 50 30]
+} -cleanup {
+ image delete photo1 photo2
+} -result {90 80 {207 146 112}}
+test imgPhoto-4.21 {ImgPhotoCmd procedure: copy option} -constraints {
+ hasTeapotPhoto
+} -setup {
+ image create photo photo1
+ image create photo photo2 -file $teapotPhotoFile
+} -body {
+ photo1 copy photo2
+ set result [list [image width photo1] [image height photo1]]
+ photo1 conf -width 49 -height 51
+ lappend result [image width photo1] [image height photo1]
+ photo1 copy photo2
+ lappend result [image width photo1] [image height photo1]
+ photo1 copy photo2 -from 0 0 10 10 -shrink
+ lappend result [image width photo1] [image height photo1]
+ photo1 conf -width 0
+ photo1 copy photo2 -from 0 0 10 10 -shrink
+ lappend result [image width photo1] [image height photo1]
+ photo1 conf -height 0
+ photo1 copy photo2 -from 0 0 10 10 -shrink
+ lappend result [image width photo1] [image height photo1]
+} -cleanup {
+ image delete photo1 photo2
+} -result {256 256 49 51 49 51 49 51 10 51 10 10}
+test imgPhoto-4.22 {ImgPhotoCmd procedure: get option} -constraints {
+ hasTeapotPhoto
+} -setup {
+ image create photo photo1
+} -body {
+ photo1 read $teapotPhotoFile
+ list [photo1 get 100 100] [photo1 get 150 100] [photo1 get 100 150]
+} -cleanup {
+ image delete photo1
+} -result {{169 117 90} {172 115 84} {35 35 35}}
+test imgPhoto-4.23 {ImgPhotoCmd procedure: get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 get 256 0
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {photo1 get: coordinates out of range}
+test imgPhoto-4.24 {ImgPhotoCmd procedure: get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 get 0 -1
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {photo1 get: coordinates out of range}
+test imgPhoto-4.25 {ImgPhotoCmd procedure: get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 get
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {wrong # args: should be "photo1 get x y"}
+test imgPhoto-4.26 {ImgPhotoCmd procedure: put option} -setup {
+ image create photo photo1
+} -body {
+ photo1 put
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {wrong # args: should be "photo1 put data ?-option value ...?"}
+test imgPhoto-4.27 {ImgPhotoCmd procedure: put option} -setup {
+ image create photo photo1
+} -body {
+ photo1 put {{white} {white white}}
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {all elements of color list must have the same number of elements}
+test imgPhoto-4.28 {ImgPhotoCmd procedure: put option} -setup {
+ image create photo photo1
+} -body {
+ photo1 put {{blahgle}}
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {can't parse color "blahgle"}
+test imgPhoto-4.29 {ImgPhotoCmd procedure: put option} -setup {
+ image create photo photo1
+} -body {
+ photo1 put -to 10 10 20 20 {{white}}
+ photo1 get 19 19
+} -cleanup {
+ image delete photo1
+} -result {255 255 255}
+test imgPhoto-4.30 {ImgPhotoCmd procedure: read option} -setup {
+ image create photo photo1
+} -body {
+ photo1 read
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {wrong # args: should be "photo1 read fileName ?-option value ...?"}
+test imgPhoto-4.31 {ImgPhotoCmd procedure: read option} -constraints {
+ hasTeapotPhoto
+} -setup {
+ image create photo photo1
+} -body {
+ photo1 read $teapotPhotoFile -zoom 2
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {unrecognized option "-zoom": must be -format, -from, -shrink, or -to}
+test imgPhoto-4.32 {ImgPhotoCmd procedure: read option} -setup {
+ image create photo photo1
+} -body {
+ list [catch {photo1 read bogus} err] [string tolower $err]
+} -cleanup {
+ image delete photo1
+} -result {1 {couldn't open "bogus": no such file or directory}}
+test imgPhoto-4.33 {ImgPhotoCmd procedure: read option} -constraints {
+ hasTeapotPhoto
+} -setup {
+ image create photo photo1
+} -body {
+ photo1 read $teapotPhotoFile -format bogus
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {image file format "bogus" is not supported}
+test imgPhoto-4.34 {ImgPhotoCmd procedure: read option} -setup {
+ image create photo photo1
+} -body {
+ photo1 read $README
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result [subst {couldn't recognize data in image file "$README"}]
+test imgPhoto-4.35 {ImgPhotoCmd procedure: read option} -constraints {
+ hasTeapotPhoto
+} -setup {
+ image create photo photo1
+} -body {
+ photo1 read $teapotPhotoFile
+ list [image width photo1] [image height photo1] [photo1 get 120 120]
+} -cleanup {
+ image delete photo1
+} -result {256 256 {161 109 82}}
+test imgPhoto-4.36 {ImgPhotoCmd procedure: read option} -constraints {
+ hasTeapotPhoto
+} -setup {
+ image create photo photo1
+} -body {
+ photo1 read $teapotPhotoFile -from 0 70 60 120 -to 10 10 -shrink
+ list [image width photo1] [image height photo1] [photo1 get 29 19]
+} -cleanup {
+ image delete photo1
+} -result {70 60 {244 180 144}}
+test imgPhoto-4.37 {ImgPhotoCmd procedure: redither option} -setup {
+ image create photo photo1
+} -body {
+ photo1 redither
+ photo1 redither x
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {wrong # args: should be "photo1 redither"}
+test imgPhoto-4.38 {ImgPhotoCmd procedure: write option} -setup {
+ image create photo photo1
+} -body {
+ photo1 write
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {wrong # args: should be "photo1 write fileName ?-option value ...?"}
+test imgPhoto-4.39 {ImgPhotoCmd procedure: write option} -setup {
+ image create photo photo1
+} -body {
+ photo1 write teapot.tmp -format bogus
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {image file format "bogus" is unknown}
+test imgPhoto-4.40 {ImgPhotoCmd procedure: transparency option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {wrong # args: should be "photo1 transparency option ?arg ...?"}
+test imgPhoto-4.41 {ImgPhotoCmd procedure: transparency get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency get
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {wrong # args: should be "photo1 transparency get x y"}
+test imgPhoto-4.42 {ImgPhotoCmd procedure: transparency get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency get 0
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {wrong # args: should be "photo1 transparency get x y"}
+test imgPhoto-4.43 {ImgPhotoCmd procedure: transparency get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency get 0 0 0
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {wrong # args: should be "photo1 transparency get x y"}
+test imgPhoto-4.44 {ImgPhotoCmd procedure: transparency get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency get bogus 0
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {expected integer but got "bogus"}
+test imgPhoto-4.45 {ImgPhotoCmd procedure: transparency get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency get 0 bogus
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {expected integer but got "bogus"}
+test imgPhoto-4.46 {ImgPhotoCmd procedure: transparency get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 put white
+ photo1 transparency get 0 0
+} -cleanup {
+ image delete photo1
+} -result 0
+test imgPhoto-4.47 {ImgPhotoCmd procedure: transparency get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency get 1 0
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {photo1 transparency get: coordinates out of range}
+test imgPhoto-4.48 {ImgPhotoCmd procedure: transparency get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency get -1 0
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {photo1 transparency get: coordinates out of range}
+test imgPhoto-4.49 {ImgPhotoCmd procedure: transparency get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency get 0 1
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {photo1 transparency get: coordinates out of range}
+test imgPhoto-4.50 {ImgPhotoCmd procedure: transparency get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency get 0 -1
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {photo1 transparency get: coordinates out of range}
+test imgPhoto-4.51 {ImgPhotoCmd procedure: transparency get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 put white
+ photo1 blank
+ photo1 transparency get 0 0
+} -cleanup {
+ image delete photo1
+} -result 1
+test imgPhoto-4.52 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency set
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {wrong # args: should be "photo1 transparency set x y boolean"}
+test imgPhoto-4.53 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency set 0
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {wrong # args: should be "photo1 transparency set x y boolean"}
+test imgPhoto-4.54 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency set 0 0
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {wrong # args: should be "photo1 transparency set x y boolean"}
+test imgPhoto-4.55 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency set 0 0 0 0
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {wrong # args: should be "photo1 transparency set x y boolean"}
+test imgPhoto-4.56 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency set bogus 0 0
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {expected integer but got "bogus"}
+test imgPhoto-4.57 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency set 0 bogus 0
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {expected integer but got "bogus"}
+test imgPhoto-4.58 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency set 0 0 bogus
+} -cleanup {
+ image delete photo1
+} -returnCodes error -result {expected boolean value but got "bogus"}
+test imgPhoto-4.59 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency set 1 0 0
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {photo1 transparency set: coordinates out of range}
+test imgPhoto-4.60 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency set -1 0 0
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {photo1 transparency set: coordinates out of range}
+test imgPhoto-4.61 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency set 0 1 0
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {photo1 transparency set: coordinates out of range}
+test imgPhoto-4.62 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency set 0 -1 0
+} -returnCodes error -cleanup {
+ image delete photo1
+} -result {photo1 transparency set: coordinates out of range}
+test imgPhoto-4.63 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 put white
+ photo1 transparency set 0 0 false
+ photo1 transparency get 0 0
+} -cleanup {
+ image delete photo1
+} -result 0
+test imgPhoto-4.64 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 put white
+ photo1 transparency set 0 0 true
+ photo1 transparency get 0 0
+} -cleanup {
+ image delete photo1
+} -result 1
+# Now for some heftier testing, checking that setting and resetting of pixels'
+# transparency status doesn't "leak" with any one-off errors.
+test imgPhoto-4.65 {ImgPhotoCmd procedure: transparency get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 put white -to 0 0 3 3
+ checkImgTrans photo1
+} -cleanup {
+ image delete photo1
+} -result {}
+test imgPhoto-4.66 {ImgPhotoCmd procedure: transparency get option} -setup {
+ image create photo photo1
+} -body {
+ photo1 put white -to 0 0 3 3
+ photo1 blank
+ checkImgTrans photo1
+} -result {0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2}
+test imgPhoto-4.67 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 put white -to 0 0 3 3
+ checkImgTransLoop photo1 {
+ photo1 put white -to 0 0 3 3
+ photo1 transparency set $x $y 1
+ } {
+ photo1 transparency set $x $y 0
}
- return $result
-}
-test imgPhoto-4.67 {ImgPhotoCmd procedure: transparency set option} {
- checkImgTransLoopSetReset p1 3 3
-} {0 0 , . 0 1 , . 0 2 , . 1 0 , . 1 1 , . 1 2 , . 2 0 , . 2 1 , . 2 2 , .}
-proc checkImgTransLoopResetSet {img width height} {
- set result {}
- for {set x 0} {$x<$width} {incr x} {
- for {set y 0} {$y<$height} {incr y} {
- $img blank
- $img transparency set $x $y 0
- set result [concat $result [checkImgTrans $img $width $height]]
- lappend result ,
- $img transparency set $x $y 1
- set result [concat $result [checkImgTrans $img $width $height]]
- lappend result .
- }
+} -cleanup {
+ image delete photo1
+} -result {0,0:. 0,1:. 0,2:. 1,0:. 1,1:. 1,2:. 2,0:. 2,1:. 2,2:.}
+test imgPhoto-4.68 {ImgPhotoCmd procedure: transparency set option} -setup {
+ image create photo photo1
+} -body {
+ photo1 put white -to 0 0 3 3
+ checkImgTransLoop photo1 {
+ photo1 blank
+ photo1 transparency set $x $y 0
+ } {
+ photo1 transparency set $x $y 1
}
- return $result
-}
-test imgPhoto-4.67a {ImgPhotoCmd procedure: transparency set option} {
- checkImgTransLoopResetSet p1 3 3
-} {0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 2 1 0 1 1 1 2 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 1 0 1 1 1 2 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 1 1 2 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 0 1 2 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 0 1 1 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 0 1 1 1 2 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 .}
-catch {rename checkImgTransLoopSetReset {}}
-catch {rename checkImgTransLoopResetSet {}}
-# Test the compositing rules for copying images
-image create photo p1 -width 3 -height 3
-image create photo p2 -width 2 -height 2
-test imgPhoto-4.68 {ImgPhotoCmd procedure: copy with -compositingrule} {
- list [catch {p1 copy p2 -to 1 1 -compositingrule} msg] $msg
-} {1 {the "-compositingrule" option requires a value}}
-test imgPhoto-4.69 {ImgPhotoCmd procedure: copy with -compositingrule} {
- list [catch {p1 copy p2 -to 1 1 -compositingrule BAD} msg] $msg
-} {1 {bad compositing rule "BAD": must be overlay or set}}
-test imgPhoto-4.70 {ImgPhotoCmd procedure: copy with -compositingrule} {
+} -cleanup {
+ image delete photo1
+} -result {0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2: 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2. 0,0 0,2 1,0 1,1 1,2 2,0 2,1 2,2: 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2. 0,0 0,1 1,0 1,1 1,2 2,0 2,1 2,2: 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2. 0,0 0,1 0,2 1,1 1,2 2,0 2,1 2,2: 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2. 0,0 0,1 0,2 1,0 1,2 2,0 2,1 2,2: 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2. 0,0 0,1 0,2 1,0 1,1 2,0 2,1 2,2: 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2. 0,0 0,1 0,2 1,0 1,1 1,2 2,1 2,2: 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2. 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,2: 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2. 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1: 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2.}
+test imgPhoto-4.69 {ImgPhotoCmd procedure: copy with -compositingrule} -setup {
+ # Test the compositing rules for copying images
+ image create photo photo1 -width 3 -height 3
+ image create photo photo2 -width 2 -height 2
+} -body {
+ photo1 copy photo2 -to 1 1 -compositingrule
+} -cleanup {
+ image delete photo1 photo2
+} -returnCodes error -result {the "-compositingrule" option requires a value}
+test imgPhoto-4.70 {ImgPhotoCmd procedure: copy with -compositingrule} -setup {
+ # Test the compositing rules for copying images
+ image create photo photo1 -width 3 -height 3
+ image create photo photo2 -width 2 -height 2
+} -body {
+ photo1 copy photo2 -to 1 1 -compositingrule BAD
+} -returnCodes error -cleanup {
+ image delete photo1 photo2
+} -result {bad compositing rule "BAD": must be overlay or set}
+test imgPhoto-4.71 {ImgPhotoCmd procedure: copy with -compositingrule} -setup {
+ # Test the compositing rules for copying images
+ image create photo photo1 -width 3 -height 3
+ image create photo photo2 -width 2 -height 2
+} -body {
# Tests default compositing rule
- p1 blank
- p2 blank
- p1 put white -to 0 0 2 2
- p2 put white -to 0 0 2 2
- p2 transparency set 0 0 true
- p1 copy p2 -to 1 1
- checkImgTrans p1 3 3
-} {0 2 2 0}
-test imgPhoto-4.71 {ImgPhotoCmd procedure: copy with -compositingrule} {
- p1 blank
- p2 blank
- p1 put white -to 0 0 2 2
- p2 put white -to 0 0 2 2
- p2 transparency set 0 0 true
- p1 copy p2 -to 1 1 -compositingrule overlay
- checkImgTrans p1 3 3
-} {0 2 2 0}
-test imgPhoto-4.72 {ImgPhotoCmd procedure: copy with -compositingrule} {
- p1 blank
- p2 blank
- p1 put white -to 0 0 2 2
- p2 put white -to 0 0 2 2
- p2 transparency set 0 0 true
- p1 copy p2 -to 1 1 -compositingrule set
- checkImgTrans p1 3 3
-} {0 2 1 1 2 0}
-catch {rename checkImgTrans {}}
+ photo1 blank
+ photo2 blank
+ photo1 put white -to 0 0 2 2
+ photo2 put white -to 0 0 2 2
+ photo2 transparency set 0 0 true
+ photo1 copy photo2 -to 1 1
+ checkImgTrans photo1
+} -cleanup {
+ image delete photo1 photo2
+} -result {0,2 2,0}
+test imgPhoto-4.72 {ImgPhotoCmd procedure: copy with -compositingrule} -setup {
+ # Test the compositing rules for copying images
+ image create photo photo1 -width 3 -height 3
+ image create photo photo2 -width 2 -height 2
+} -body {
+ photo1 blank
+ photo2 blank
+ photo1 put white -to 0 0 2 2
+ photo2 put white -to 0 0 2 2
+ photo2 transparency set 0 0 true
+ photo1 copy photo2 -to 1 1 -compositingrule overlay
+ checkImgTrans photo1
+} -cleanup {
+ image delete photo1 photo2
+} -result {0,2 2,0}
+test imgPhoto-4.73 {ImgPhotoCmd procedure: copy with -compositingrule} -setup {
+ # Test the compositing rules for copying images
+ image create photo photo1 -width 3 -height 3
+ image create photo photo2 -width 2 -height 2
+} -body {
+ photo1 blank
+ photo2 blank
+ photo1 put white -to 0 0 2 2
+ photo2 put white -to 0 0 2 2
+ photo2 transparency set 0 0 true
+ photo1 copy photo2 -to 1 1 -compositingrule set
+ checkImgTrans photo1
+} -cleanup {
+ image delete photo1 photo2
+} -result {0,2 1,1 2,0}
-test imgPhoto-5.1 {ImgPhotoGet/Free procedures, shared instances} hasTeapotPhoto {
- eval image delete [image names]
- .c delete all
- image create photo p1 -file $teapotPhotoFile
- .c create image 0 0 -image p1 -tags p1.1
- .c create image 256 0 -image p1 -tags p1.2
- .c create image 0 256 -image p1 -tags p1.3
+test imgPhoto-5.1 {ImgPhotoGet/Free procedures, shared instances} -constraints {
+ hasTeapotPhoto
+} -setup {
+ destroy .c
+ pack [canvas .c]
+ imageCleanup
+} -body {
+ image create photo photo1 -file $teapotPhotoFile
+ .c create image 0 0 -image photo1 -tags photo1.1
+ .c create image 256 0 -image photo1 -tags photo1.2
+ .c create image 0 256 -image photo1 -tags photo1.3
update
.c delete i1.1
- p1 configure -width 1
+ photo1 configure -width 1
update
.c delete i1.2
- p1 configure -height 1
+ photo1 configure -height 1
update
- image delete p1
-} {}
+ image delete photo1
+} -cleanup {
+ destroy .c
+} -result {}
-test imgPhoto-6.1 {ImgPhotoDisplay procedure, blank display} {
- .c delete all
- image create photo p1 -width 10 -height 10
- p1 blank
- .c create image 10 10 -image p1
+test imgPhoto-6.1 {ImgPhotoDisplay procedure, blank display} -setup {
+ destroy .c
+ pack [canvas .c]
+ imageCleanup
+} -body {
+ image create photo photo1 -width 10 -height 10
+ photo1 blank
+ .c create image 10 10 -image photo1
update
-} {}
+} -cleanup {
+ destroy .c
+ image delete photo1
+} -result {}
-test imgPhoto-7.1 {ImgPhotoFree procedure, resource freeing} hasTeapotPhoto {
- eval image delete [image names]
- .c delete all
- image create photo p1 -file $teapotPhotoFile
- .c create image 0 0 -image p1 -anchor nw
+test imgPhoto-7.1 {ImgPhotoFree procedure, resource freeing} -constraints {
+ hasTeapotPhoto
+} -setup {
+ destroy .c
+ pack [canvas .c]
+ imageCleanup
+} -body {
+ image create photo photo1 -file $teapotPhotoFile
+ .c create image 0 0 -image photo1 -anchor nw
update
.c delete all
- image delete p1
-} {}
-test imgPhoto-7.2 {ImgPhotoFree procedures, unlinking} hasTeapotPhoto {
- image create photo p1 -file $teapotPhotoFile
- .c create image 10 10 -image p1 -anchor nw
- button .b1 -image p1
- button .b2 -image p1
- button .b3 -image p1
+ image delete photo1
+} -cleanup {
+ destroy .c
+} -result {}
+test imgPhoto-7.2 {ImgPhotoFree procedures, unlinking} -constraints {
+ hasTeapotPhoto
+} -setup {
+ deleteWindows
+ imageCleanup
+} -body {
+ image create photo photo1 -file $teapotPhotoFile
+ pack [canvas .c]
+ .c create image 10 10 -image photo1 -anchor nw
+ button .b1 -image photo1
+ button .b2 -image photo1
+ button .b3 -image photo1
pack .b1 .b2 .b3
update
destroy .b2
@@ -490,12 +871,20 @@ test imgPhoto-7.2 {ImgPhotoFree procedures, unlinking} hasTeapotPhoto {
destroy .b1
update
.c delete all
-} {}
-test imgPhoto-7.3 {ImgPhotoFree procedures, multiple visuals} hasTeapotPhoto {
- image create photo p1 -file $teapotPhotoFile
- button .b1 -image p1
+} -cleanup {
+ destroy .c
+ image delete photo1
+} -result {}
+test imgPhoto-7.3 {ImgPhotoFree procedures, multiple visuals} -constraints {
+ hasTeapotPhoto
+} -setup {
+ deleteWindows
+ imageCleanup
+} -body {
+ image create photo photo1 -file $teapotPhotoFile
+ button .b1 -image photo1
frame .f -visual best
- button .f.b2 -image p1
+ button .f.b2 -image photo1
pack .f.b2
pack .b1 .f
update
@@ -504,59 +893,71 @@ test imgPhoto-7.3 {ImgPhotoFree procedures, multiple visuals} hasTeapotPhoto {
.f.b2 configure -image {}
update
destroy .f
- image delete p1
-} {}
+ image delete photo1
+} -result {}
-test imgPhoto-8.1 {ImgPhotoDelete procedure} hasTeapotPhoto {
- image create photo p2 -file $teapotPhotoFile
- image delete p2
-} {}
-test imagePhoto-8.2 {ImgPhotoDelete procedure} hasTeapotPhoto {
- image create photo p2 -file $teapotPhotoFile
- rename p2 newp2
- set x [list [info command p2] [info command new*] [newp2 cget -file]]
- image delete p2
- append x [info command new*]
-} [list {} newp2 $teapotPhotoFile]
-test imagePhoto-8.3 {ImgPhotoDelete procedure, name cleanup} {
- image create photo p1
- image create photo p2 -width 10 -height 10
- image delete p2
- list [catch {p1 copy p2} msg] $msg
-} {1 {image "p2" doesn't exist or is not a photo image}}
+test imgPhoto-8.1 {ImgPhotoDelete procedure} -constraints hasTeapotPhoto -body {
+ image create photo photo2 -file $teapotPhotoFile
+ image delete photo2
+} -result {}
+test imgPhoto-8.2 {ImgPhotoDelete procedure} -constraints {
+ hasTeapotPhoto
+} -setup {
+ set x {}
+} -body {
+ image create photo photo2 -file $teapotPhotoFile
+ rename photo2 newphoto2
+ lappend x [info command photo2] [info command new*] [newphoto2 cget -file]
+ image delete photo2
+ lappend x [info command new*]
+} -result [list {} newphoto2 $teapotPhotoFile {}]
+test imgPhoto-8.3 {ImgPhotoDelete procedure, name cleanup} -body {
+ image create photo photo1
+ image create photo photo2 -width 10 -height 10
+ image delete photo2
+ photo1 copy photo2
+} -returnCodes error -cleanup {
+ imageCleanup
+} -result {image "photo2" doesn't exist or is not a photo image}
-test imagePhoto-9.1 {ImgPhotoCmdDeletedProc procedure} hasTeapotPhoto {
- image create photo p2 -file $teapotPhotoFile
- rename p2 {}
- list [lsearch -exact [image names] p2] [catch {p2 foo} msg] $msg
-} {-1 1 {invalid command name "p2"}}
+test imgPhoto-9.1 {ImgPhotoCmdDeletedProc procedure} -constraints {
+ hasTeapotPhoto
+} -body {
+ image create photo photo2 -file $teapotPhotoFile
+ rename photo2 {}
+ list [lsearch -exact [imageNames] photo2] [catch {photo2 foo} msg] $msg
+} -result {-1 1 {invalid command name "photo2"}}
-test imgPhoto-10.1 {Tk_ImgPhotoPutBlock procedure} {
- eval image delete [image names]
- image create photo p1
- p1 put {{#ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000}} -to 0 0
- p1 put {{#00ff00 #00ff00}} -to 2 0
- list [p1 get 2 0] [p1 get 3 0] [p1 get 4 0]
-} {{0 255 0} {0 255 0} {255 0 0}}
+test imgPhoto-10.1 {Tk_ImgPhotoPutBlock procedure} -setup {
+ imageCleanup
+} -body {
+ image create photo photo1
+ photo1 put "{#ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000}" -to 0 0
+ photo1 put "{#00ff00 #00ff00}" -to 2 0
+ list [photo1 get 2 0] [photo1 get 3 0] [photo1 get 4 0]
+} -result {{0 255 0} {0 255 0} {255 0 0}}
-test imgPhoto-11.1 {Tk_FindPhoto} {
- eval image delete [image names]
+test imgPhoto-11.1 {Tk_FindPhoto} -setup {
+ imageCleanup
+} -body {
image create bitmap i1
- image create photo p1
- list [catch {p1 copy i1} msg] $msg
-} {1 {image "i1" doesn't exist or is not a photo image}}
+ image create photo photo1
+ photo1 copy i1
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result {image "i1" doesn't exist or is not a photo image}
-test imgPhoto-12.1 {Tk_PhotoPutZoomedBlock} hasTeapotPhoto {
+test imgPhoto-12.1 {Tk_PhotoPutZoomedBlock} -constraints hasTeapotPhoto -body {
image create photo p3 -file $teapotPhotoFile
set result [list [p3 get 50 50] [p3 get 100 100]]
p3 copy p3 -zoom 2
lappend result [image width p3] [image height p3] [p3 get 100 100]
+} -cleanup {
image delete p3
- set result
-} {{19 92 192} {169 117 90} 512 512 {19 92 192}}
+} -result {{19 92 192} {169 117 90} 512 512 {19 92 192}}
-test imgPhoto-13.1 {check separation of images in different interpreters} {
- image delete {*}[image names]
+test imgPhoto-13.1 {check separation of images in different interpreters} -setup {
+ imageCleanup
set data {
R0lGODlhQgBkAPUAANbWxs7Wxs7OxsbOxsbGxsbGvb3Gvca9vcDAwL21vbW1vbW1tbWtta2t
ta2ltaWltaWlraWctaWcrZycrZyUrZSUrZSMrZSMpYyMrYyMpYyEpYSEpYR7pYR7nHp7pYRz
@@ -592,82 +993,79 @@ test imgPhoto-13.1 {check separation of images in different interpreters} {
interp create x2
x1 eval {load {} Tk}
x2 eval {load {} Tk}
+} -body {
x1 eval [list image create photo T1_data -data $data]
x2 eval [list image create photo T1_data -data $data]
- unset data
+} -cleanup {
interp delete x1
interp delete x2
-} {}
+} -result T1_data
-test imgPhoto-14.1 {GIF writes work correctly} {
- set data "R0lGODlhYwA5APcAAAAAAIAAAACAAICAAAAAgIAAgACAgICAgAysnGy8hKzM
-hASs3MTcjAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
-AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
-AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
-AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
-AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
-AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
-AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
-AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
-AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
-AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
-AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
-AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
-AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
-AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
-AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
-AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAMDAwP8AAAD/
-AP//AAAA//8A/wD//////ywAAAAAYwA5AAAI/wAZCBxIsKDBgwgTKlzIsKHD
-hxAjSpxIsaLFixgzatzIsaPHjyBDihxJsqTJkyhTqlzJsqXLlzBjypxJs6bN
-mzhz6tzJs6fPn0CDCh1KtKhRiwoSKEXAtGlTpUqPGkyagOmCq1edNsWalWkC
-BUSXIuDqFepBqFWtZv3KU+zYrkrBSqT6dgECtjOTbu16NwFHvV3lshRLti/J
-qlgRCE6ZuO9ik4Dt+k0ZVyZiyVIvXr77ODPEy5g9T4zMWfTEzXdNz1VbWvXn
-uqldP1TAOrbshqBb314Y2W7n3Qdpv7UNPCHpycUVbv6dnODy5sqzQldIe8H0
-hciva9/Ovbv37+BzBgEEADs=
-"
- set photo [image create photo -data $data]
- set filename [makeFile {} imgPhoto-14.1.gif]
- removeFile imgPhoto-14.1.gif
- $photo write $filename -format gif
- set photo2 [image create photo -file $filename]
- set result [string equal [$photo data] [$photo2 data]]
- image delete $photo $photo2
- catch {file delete -force $filename}
- set result
-} 1
-test imgPhoto-14.2 {GIF -index handler buffer sizing} -setup {
- set i [image create photo]
+test imgPhoto-14.1 {GIF writes work correctly} -setup {
+ set data {
+ R0lGODlhYwA5APcAAAAAAIAAAACAAICAAAAAgIAAgACAgICAgAysnGy8hKzM
+ hASs3MTcjAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAMDAwP8AAAD/
+ AP//AAAA//8A/wD//////ywAAAAAYwA5AAAI/wAZCBxIsKDBgwgTKlzIsKHD
+ hxAjSpxIsaLFixgzatzIsaPHjyBDihxJsqTJkyhTqlzJsqXLlzBjypxJs6bN
+ mzhz6tzJs6fPn0CDCh1KtKhRiwoSKEXAtGlTpUqPGkyagOmCq1edNsWalWkC
+ BUSXIuDqFepBqFWtZv3KU+zYrkrBSqT6dgECtjOTbu16NwFHvV3lshRLti/J
+ qlgRCE6ZuO9ik4Dt+k0ZVyZiyVIvXr77ODPEy5g9T4zMWfTEzXdNz1VbWvXn
+ uqldP1TAOrbshqBb314Y2W7n3Qdpv7UNPCHpycUVbv6dnODy5sqzQldIe8H0
+ hciva9/Ovbv37+BzBgEEADs=
+ }
+ set tmpfilename [makeFile {} imgPhoto-14.1.gif]
+ removeFile $tmpfilename
} -body {
- # Bug 1458234 makes this crash when trying to access buffers of the
- # wrong size, caused when the initial frame is not the largest frame.
+ image create photo photo1 -data $data
+ photo1 write $tmpfilename -format gif
+ image create photo photo2 -file $tmpfilename
+ string equal [photo1 data] [photo2 data]
+} -cleanup {
+ catch {image delete photo1 photo2}
+ catch {file delete -force $tmpfilename}
+} -result 1
+test imgPhoto-14.2 {GIF -index handler buffer sizing} -setup {
set data {
R0lGODlhIAAgAKEAAPkOSQsi7////////yH/C05FVFNDQVBFMi4wAwEAAAAh
+QQJMgAAACwGAAYAFAAUAAACEYyPqcvtD6OctNqLs968+68VACH5BAkyAAEA
LAMAAwAaABoAAAI0jH+gq+gfmFzQzUsr3gBybn1gIm5kaUaoubbuC8fyTNel
Ohv1CSO533u8KrgbUfc5Ci/EAgA7
}
+} -body {
+ # Bug 1458234 makes this crash when trying to access buffers of the wrong
+ # size, caused when the initial frame is not the largest frame.
+ set i [image create photo]
$i configure -data $data -format {gif -index 2}
} -cleanup {
image delete $i
} -returnCodes error -result {no image data for this index}
-
-test imgPhoto-14.3 {GIF -index interleaving and small frames} -setup {
+test imgPhoto-14.3 {GIF -index interleaving and small frames} -body {
+ # Interleaved GIFs used to crash us when a smaller subsequent frame was
+ # accessed.
set i [image create photo]
-} -body {
- # Interleaved GIFs used to crash us when a smaller subsequent frame
- # was accessed.
$i configure -format {GIF -index 1} -data {
R0lGODdhAQAFAPAAAP8AAAAAACwAAAAAAQAFAEACAoRdACwAAAAAAQAEAEACAoRRADs=
}
} -cleanup {
image delete $i
}
-
test imgPhoto-14.4 {GIF buffer overflow} -setup {
- set i [image create photo]
-} -body {
- # This crashes Tk up to 8.4.17 and 8.5.0
- $i configure -data {
+ set data {
R0lGODlhCgAKAPcAAAAAAIAAAACAAICAAAAAgIAAgACAgICAgMDAwP8AAAD/
AP//AAAA//8A/wD//////wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
@@ -687,30 +1085,85 @@ test imgPhoto-14.4 {GIF buffer overflow} -setup {
mf9mzP9m//+ZAP+ZM/+ZZv+Zmf+ZzP+Z///MAP/MM//MZv/Mmf/MzP/M////
AP//M///Zv//mf//zP///yH5BAEAABAALAAAAAAKAAoAABUSAAD/HEiwoMGD
CBMqXMiwYcKAADs=
- }
+ }
+} -body {
+ # This crashes Tk up to 8.4.17 and 8.5.0
+ set i [image create photo]
+ $i configure -data $data
} -cleanup {
image delete $i
} -returnCodes error -result {malformed image}
-test imgPhoto-15.1 {photo images can fail to allocate memory gracefully} \
- {nonPortable} {
- # This is not portable to very large machines with more around
- # 3GB of free memory available...
- list [catch {image create photo -width 32000 -height 32000} msg] $msg
-} {1 {not enough free memory for image buffer}}
+test imgPhoto-15.1 {photo images can fail to allocate memory gracefully} -constraints {
+ nonPortable
+} -body {
+ # This is not portable to very large machines with more than around 3GB of
+ # free memory available...
+ image create photo -width 32000 -height 32000
+} -returnCodes error -result {not enough free memory for image buffer}
-test imgPhoto-16.1 {copying to self doesn't access freed memory} {
- # Bug 877950 makes this crash when trying to copy out of a deallocated area
+test imgPhoto-16.1 {copying to self doesn't access freed memory} -setup {
set i [image create photo]
+} -body {
+ # Bug 877950 makes this crash when trying to copy out of a deallocated
+ # area.
$i put red -to 0 0 1000 1000
$i copy $i -from 0 0 1000 1000 -to 500 0
+} -cleanup {
+ image delete $i
+} -result {}
+
+# Check that we can guess our supported output formats [Bug 2983824]
+test imgPhoto-17.1 {photo write: format guessing from filename} -setup {
+ set i [image create photo -width 3 -height 3]
+} -body {
+ set f [makeFile {} test.png]
+ $i write $f
+ set fd [open $f]
+ seek $fd 1
+ read $fd 3
+} -cleanup {
+ catch {close $fd}
+ image delete $i
+ catch {removeFile $f}
+} -result PNG
+test imgPhoto-17.2 {photo write: format guessing from filename} -setup {
+ set i [image create photo -width 3 -height 3]
+} -body {
+ set f [makeFile {} test.gif]
+ $i write $f
+ set fd [open $f]
+ read $fd 3
+} -cleanup {
+ catch {close $fd}
+ image delete $i
+ catch {removeFile $f}
+} -result GIF
+test imgPhoto-17.3 {photo write: format guessing from filename} -setup {
+ set i [image create photo -width 3 -height 3]
+} -body {
+ set f [makeFile {} test.ppm]
+ $i write $f
+ set fd [open $f]
+ read $fd 3
+} -cleanup {
+ catch {close $fd}
image delete $i
-} {}
+ catch {removeFile $f}
+} -result "P6\n"
-destroy .c
-eval image delete [image names]
+# ----------------------------------------------------------------------
+
+catch {rename foreachPixel {}}
+catch {rename checkImgTrans {}}
+catch {rename checkImgTransLoop {}}
+imageFinish
# cleanup
removeFile README-imgPhoto
cleanupTests
return
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tests/listbox.test b/tests/listbox.test
index 25bc606..0805528 100644
--- a/tests/listbox.test
+++ b/tests/listbox.test
@@ -6,9 +6,10 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
+namespace import -force tcltest::test
set fixed {Courier -12}
@@ -39,7 +40,7 @@ proc resetGridInfo {} {
# to partially visible lines.
proc mkPartial {{w .partial}} {
- catch {destroy $w}
+ destroy $w
toplevel $w
wm geometry $w +0+0
listbox $w.l -width 30 -height 5
@@ -59,128 +60,332 @@ option add *Listbox.borderWidth 2
option add *Listbox.highlightThickness 2
option add *Listbox.font {Helvetica -12 bold}
+# Listbox used in 3.* configuration options tests
listbox .l
pack .l
update
resetGridInfo
-set i 1
-
-foreach test {
- {-activestyle under underline foo {bad activestyle "foo": must be dotbox, none, or underline}}
- {-background #ff0000 #ff0000 non-existent
- {unknown color name "non-existent"}}
- {-bd 4 4 badValue {bad screen distance "badValue"}}
- {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}}
- {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
- {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
- {-disabledforeground #110022 #110022 bogus {unknown color name "bogus"}}
- {-exportselection yes 1 xyzzy {expected boolean value but got "xyzzy"}}
- {-fg #110022 #110022 bogus {unknown color name "bogus"}}
- {-font {Helvetica 12} {Helvetica 12} {} {font "" doesn't exist}}
- {-foreground #110022 #110022 bogus {unknown color name "bogus"}}
- {-height 30 30 20p {expected integer but got "20p"}}
- {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}}
- {-highlightcolor #123456 #123456 bogus {unknown color name "bogus"}}
- {-highlightthickness 6 6 bogus {bad screen distance "bogus"}}
- {-highlightthickness -2 0 {} {}}
- {-relief groove groove 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}}
- {-selectbackground #110022 #110022 bogus {unknown color name "bogus"}}
- {-selectborderwidth 1.3 1 badValue {bad screen distance "badValue"}}
- {-selectforeground #654321 #654321 bogus {unknown color name "bogus"}}
- {-selectmode string string {} {}}
- {-setgrid false 0 lousy {expected boolean value but got "lousy"}}
- {-state disabled disabled foo {bad state "foo": must be disabled or normal}}
- {-takefocus "any string" "any string" {} {}}
- {-width 45 45 3p {expected integer but got "3p"}}
- {-xscrollcommand {Some command} {Some command} {} {}}
- {-yscrollcommand {Another command} {Another command} {} {}}
- {-listvar testVariable testVariable {} {}}
-} {
- set name [lindex $test 0]
- test listbox-1.$i {configuration options} {
- .l configure $name [lindex $test 1]
- list [lindex [.l configure $name] 4] [.l cget $name]
- } [list [lindex $test 2] [lindex $test 2]]
- incr i
- if {[lindex $test 3] != ""} {
- test listbox-1.$i {configuration options} {
- list [catch {.l configure $name [lindex $test 3]} msg] $msg
- } [list 1 [lindex $test 4]]
- }
- .l configure $name [lindex [.l configure $name] 3]
- incr i
-}
+test listbox-1.1 {configuration options} -body {
+ .l configure -activestyle under
+ list [lindex [.l configure -activestyle] 4] [.l cget -activestyle]
+} -cleanup {
+ .l configure -activestyle [lindex [.l configure -activestyle] 3]
+} -result {underline underline}
+test listbox-1.2 {configuration options} -body {
+ .l configure -activestyle foo
+} -returnCodes error -result {bad activestyle "foo": must be dotbox, none, or underline}
+test listbox-1.3 {configuration options} -body {
+ .l configure -background #ff0000
+ list [lindex [.l configure -background] 4] [.l cget -background]
+} -cleanup {
+ .l configure -background [lindex [.l configure -background] 3]
+} -result {{#ff0000} #ff0000}
+test listbox-1.4 {configuration options} -body {
+ .l configure -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test listbox-1.5 {configuration options} -body {
+ .l configure -bd 4
+ list [lindex [.l configure -bd] 4] [.l cget -bd]
+} -cleanup {
+ .l configure -bd [lindex [.l configure -bd] 3]
+} -result {4 4}
+test listbox-1.6 {configuration options} -body {
+ .l configure -bd badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test listbox-1.7 {configuration options} -body {
+ .l configure -bg #ff0000
+ list [lindex [.l configure -bg] 4] [.l cget -bg]
+} -cleanup {
+ .l configure -bg [lindex [.l configure -bg] 3]
+} -result {{#ff0000} #ff0000}
+test listbox-1.8 {configuration options} -body {
+ .l configure -bg non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test listbox-1.9 {configuration options} -body {
+ .l configure -borderwidth 1.3
+ list [lindex [.l configure -borderwidth] 4] [.l cget -borderwidth]
+} -cleanup {
+ .l configure -borderwidth [lindex [.l configure -borderwidth] 3]
+} -result {1 1}
+test listbox-1.10 {configuration options} -body {
+ .l configure -borderwidth badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test listbox-1.11 {configuration options} -body {
+ .l configure -cursor arrow
+ list [lindex [.l configure -cursor] 4] [.l cget -cursor]
+} -cleanup {
+ .l configure -cursor [lindex [.l configure -cursor] 3]
+} -result {arrow arrow}
+test listbox-1.12 {configuration options} -body {
+ .l configure -cursor badValue
+} -returnCodes error -result {bad cursor spec "badValue"}
+test listbox-1.13 {configuration options} -body {
+ .l configure -disabledforeground #110022
+ list [lindex [.l configure -disabledforeground] 4] [.l cget -disabledforeground]
+} -cleanup {
+ .l configure -disabledforeground [lindex [.l configure -disabledforeground] 3]
+} -result {{#110022} #110022}
+test listbox-1.14 {configuration options} -body {
+ .l configure -disabledforeground bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test listbox-1.15 {configuration options} -body {
+ .l configure -exportselection yes
+ list [lindex [.l configure -exportselection] 4] [.l cget -exportselection]
+} -cleanup {
+ .l configure -exportselection [lindex [.l configure -exportselection] 3]
+} -result {1 1}
+test listbox-1.16 {configuration options} -body {
+ .l configure -exportselection xyzzy
+} -returnCodes error -result {expected boolean value but got "xyzzy"}
+test listbox-1.17 {configuration options} -body {
+ .l configure -fg #110022
+ list [lindex [.l configure -fg] 4] [.l cget -fg]
+} -cleanup {
+ .l configure -fg [lindex [.l configure -fg] 3]
+} -result {{#110022} #110022}
+test listbox-1.18 {configuration options} -body {
+ .l configure -fg bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test listbox-1.19 {configuration options} -body {
+ .l configure -font {Helvetica 12}
+ list [lindex [.l configure -font] 4] [.l cget -font]
+} -cleanup {
+ .l configure -font [lindex [.l configure -font] 3]
+} -result {{Helvetica 12} {Helvetica 12}}
+test listbox-1.21 {configuration options} -body {
+ .l configure -foreground #110022
+ list [lindex [.l configure -foreground] 4] [.l cget -foreground]
+} -cleanup {
+ .l configure -foreground [lindex [.l configure -foreground] 3]
+} -result {{#110022} #110022}
+test listbox-1.22 {configuration options} -body {
+ .l configure -foreground bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test listbox-1.23 {configuration options} -body {
+ .l configure -height 30
+ list [lindex [.l configure -height] 4] [.l cget -height]
+} -cleanup {
+ .l configure -height [lindex [.l configure -height] 3]
+} -result {30 30}
+test listbox-1.24 {configuration options} -body {
+ .l configure -height 20p
+} -returnCodes error -result {expected integer but got "20p"}
+test listbox-1.25 {configuration options} -body {
+ .l configure -highlightbackground #112233
+ list [lindex [.l configure -highlightbackground] 4] [.l cget -highlightbackground]
+} -cleanup {
+ .l configure -highlightbackground [lindex [.l configure -highlightbackground] 3]
+} -result {{#112233} #112233}
+test listbox-1.26 {configuration options} -body {
+ .l configure -highlightbackground ugly
+} -returnCodes error -result {unknown color name "ugly"}
+test listbox-1.27 {configuration options} -body {
+ .l configure -highlightcolor #123456
+ list [lindex [.l configure -highlightcolor] 4] [.l cget -highlightcolor]
+} -cleanup {
+ .l configure -highlightcolor [lindex [.l configure -highlightcolor] 3]
+} -result {{#123456} #123456}
+test listbox-1.28 {configuration options} -body {
+ .l configure -highlightcolor bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test listbox-1.29 {configuration options} -body {
+ .l configure -highlightthickness 6
+ list [lindex [.l configure -highlightthickness] 4] [.l cget -highlightthickness]
+} -cleanup {
+ .l configure -highlightthickness [lindex [.l configure -highlightthickness] 3]
+} -result {6 6}
+test listbox-1.30 {configuration options} -body {
+ .l configure -highlightthickness bogus
+} -returnCodes error -result {bad screen distance "bogus"}
+test listbox-1.31 {configuration options} -body {
+ .l configure -highlightthickness -2
+ list [lindex [.l configure -highlightthickness] 4] [.l cget -highlightthickness]
+} -cleanup {
+ .l configure -highlightthickness [lindex [.l configure -highlightthickness] 3]
+} -result {0 0}
+test listbox-1.33 {configuration options} -body {
+ .l configure -relief groove
+ list [lindex [.l configure -relief] 4] [.l cget -relief]
+} -cleanup {
+ .l configure -relief [lindex [.l configure -relief] 3]
+} -result {groove groove}
+test listbox-1.34 {configuration options} -body {
+ .l configure -relief 1.5
+} -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+test listbox-1.35 {configuration options} -body {
+ .l configure -selectbackground #110022
+ list [lindex [.l configure -selectbackground] 4] [.l cget -selectbackground]
+} -cleanup {
+ .l configure -selectbackground [lindex [.l configure -selectbackground] 3]
+} -result {{#110022} #110022}
+test listbox-1.36 {configuration options} -body {
+ .l configure -selectbackground bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test listbox-1.37 {configuration options} -body {
+ .l configure -selectborderwidth 1.3
+ list [lindex [.l configure -selectborderwidth] 4] [.l cget -selectborderwidth]
+} -cleanup {
+ .l configure -selectborderwidth [lindex [.l configure -selectborderwidth] 3]
+} -result {1 1}
+test listbox-1.38 {configuration options} -body {
+ .l configure -selectborderwidth badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test listbox-1.39 {configuration options} -body {
+ .l configure -selectforeground #654321
+ list [lindex [.l configure -selectforeground] 4] [.l cget -selectforeground]
+} -cleanup {
+ .l configure -selectforeground [lindex [.l configure -selectforeground] 3]
+} -result {{#654321} #654321}
+test listbox-1.40 {configuration options} -body {
+ .l configure -selectforeground bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test listbox-1.41 {configuration options} -body {
+ .l configure -selectmode string
+ list [lindex [.l configure -selectmode] 4] [.l cget -selectmode]
+} -cleanup {
+ .l configure -selectmode [lindex [.l configure -selectmode] 3]
+} -result {string string}
+test listbox-1.43 {configuration options} -body {
+ .l configure -setgrid false
+ list [lindex [.l configure -setgrid] 4] [.l cget -setgrid]
+} -cleanup {
+ .l configure -setgrid [lindex [.l configure -setgrid] 3]
+} -result {0 0}
+test listbox-1.44 {configuration options} -body {
+ .l configure -setgrid lousy
+} -returnCodes error -result {expected boolean value but got "lousy"}
+test listbox-1.45 {configuration options} -body {
+ .l configure -state disabled
+ list [lindex [.l configure -state] 4] [.l cget -state]
+} -cleanup {
+ .l configure -state [lindex [.l configure -state] 3]
+} -result {disabled disabled}
+test listbox-1.46 {configuration options} -body {
+ .l configure -state foo
+} -returnCodes error -result {bad state "foo": must be disabled or normal}
+test listbox-1.47 {configuration options} -body {
+ .l configure -takefocus {any string}
+ list [lindex [.l configure -takefocus] 4] [.l cget -takefocus]
+} -cleanup {
+ .l configure -takefocus [lindex [.l configure -takefocus] 3]
+} -result {{any string} {any string}}
+test listbox-1.49 {configuration options} -body {
+ .l configure -width 45
+ list [lindex [.l configure -width] 4] [.l cget -width]
+} -cleanup {
+ .l configure -width [lindex [.l configure -width] 3]
+} -result {45 45}
+test listbox-1.50 {configuration options} -body {
+ .l configure -width 3p
+} -returnCodes error -result {expected integer but got "3p"}
+test listbox-1.51 {configuration options} -body {
+ .l configure -xscrollcommand {Some command}
+ list [lindex [.l configure -xscrollcommand] 4] [.l cget -xscrollcommand]
+} -cleanup {
+ .l configure -xscrollcommand [lindex [.l configure -xscrollcommand] 3]
+} -result {{Some command} {Some command}}
+test listbox-1.53 {configuration options} -body {
+ .l configure -yscrollcommand {Another command}
+ list [lindex [.l configure -yscrollcommand] 4] [.l cget -yscrollcommand]
+} -cleanup {
+ .l configure -yscrollcommand [lindex [.l configure -yscrollcommand] 3]
+} -result {{Another command} {Another command}}
+test listbox-1.55 {configuration options} -body {
+ .l configure -listvar testVariable
+ list [lindex [.l configure -listvar] 4] [.l cget -listvar]
+} -cleanup {
+ .l configure -listvar [lindex [.l configure -listvar] 3]
+} -result {testVariable testVariable}
+
-test listbox-2.1 {Tk_ListboxCmd procedure} {
- list [catch {listbox} msg] $msg
-} {1 {wrong # args: should be "listbox pathName ?options?"}}
-test listbox-2.2 {Tk_ListboxCmd procedure} {
- list [catch {listbox gorp} msg] $msg
-} {1 {bad window path name "gorp"}}
-test listbox-2.3 {Tk_ListboxCmd procedure} {
- catch {destroy .l}
+test listbox-2.1 {Tk_ListboxCmd procedure} -body {
+ listbox
+} -returnCodes error -result {wrong # args: should be "listbox pathName ?-option value ...?"}
+test listbox-2.2 {Tk_ListboxCmd procedure} -body {
+ listbox gorp
+} -returnCodes error -result {bad window path name "gorp"}
+test listbox-2.3 {Tk_ListboxCmd procedure} -setup {
+ destroy .l
+} -body {
listbox .l
list [winfo exists .l] [winfo class .l] [info commands .l]
-} {1 Listbox .l}
-test listbox-2.4 {Tk_ListboxCmd procedure} {
- catch {destroy .l}
- list [catch {listbox .l -gorp foo} msg] $msg [winfo exists .l] \
- [info commands .l]
-} {1 {unknown option "-gorp"} 0 {}}
-test listbox-2.5 {Tk_ListboxCmd procedure} {
- catch {destroy .l}
+} -result {1 Listbox .l}
+test listbox-2.4 {Tk_ListboxCmd procedure} -setup {
+ destroy .l
+} -body {
+ listbox .l -gorp foo
+} -cleanup {
+ destroy .l
+} -returnCodes error -result {unknown option "-gorp"}
+test listbox-2.4.1 {Tk_ListboxCmd procedure} -setup {
+ destroy .l
+} -body {
+ catch {listbox .l -gorp foo}
+ list [winfo exists .l] [info commands .l]
+} -cleanup {
+ destroy .l
+} -result {0 {}}
+test listbox-2.5 {Tk_ListboxCmd procedure} -setup {
+ destroy .l
+} -body {
listbox .l
-} {.l}
+} -cleanup {
+ destroy .l
+} -result {.l}
-catch {destroy .l}
+
+# Listbox used in 3.1 -3.115 tests
+destroy .l
listbox .l -width 20 -height 5 -bd 4 -highlightthickness 1 -selectborderwidth 2
pack .l
.l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 el12 el13 el14 \
el15 el16 el17
update
-test listbox-3.1 {ListboxWidgetCmd procedure} {
- list [catch .l msg] $msg
-} {1 {wrong # args: should be ".l option ?arg arg ...?"}}
-test listbox-3.2 {ListboxWidgetCmd procedure, "activate" option} {
- list [catch {.l activate} msg] $msg
-} {1 {wrong # args: should be ".l activate index"}}
-test listbox-3.3 {ListboxWidgetCmd procedure, "activate" option} {
- list [catch {.l activate a b} msg] $msg
-} {1 {wrong # args: should be ".l activate index"}}
-test listbox-3.4 {ListboxWidgetCmd procedure, "activate" option} {
- list [catch {.l activate fooey} msg] $msg
-} {1 {bad listbox index "fooey": must be active, anchor, end, @x,y, or a number}}
-test listbox-3.5 {ListboxWidgetCmd procedure, "activate" option} {
+test listbox-3.1 {ListboxWidgetCmd procedure} -body {
+ .l
+} -returnCodes error -result {wrong # args: should be ".l option ?arg ...?"}
+test listbox-3.2 {ListboxWidgetCmd procedure, "activate" option} -body {
+ .l activate
+} -returnCodes error -result {wrong # args: should be ".l activate index"}
+test listbox-3.3 {ListboxWidgetCmd procedure, "activate" option} -body {
+ .l activate a b
+} -returnCodes error -result {wrong # args: should be ".l activate index"}
+test listbox-3.4 {ListboxWidgetCmd procedure, "activate" option} -body {
+ .l activate fooey
+} -returnCodes error -result {bad listbox index "fooey": must be active, anchor, end, @x,y, or a number}
+test listbox-3.5 {ListboxWidgetCmd procedure, "activate" option} -body {
.l activate 3
.l index active
-} 3
-test listbox-3.6 {ListboxWidgetCmd procedure, "activate" option} {
+} -result 3
+test listbox-3.6 {ListboxWidgetCmd procedure, "activate" option} -body {
.l activate -1
.l index active
-} {0}
-test listbox-3.7 {ListboxWidgetCmd procedure, "activate" option} {
+} -result {0}
+test listbox-3.7 {ListboxWidgetCmd procedure, "activate" option} -body {
.l activate 30
.l index active
-} {17}
-test listbox-3.8 {ListboxWidgetCmd procedure, "activate" option} {
+} -result {17}
+test listbox-3.8 {ListboxWidgetCmd procedure, "activate" option} -body {
.l activate end
.l index active
-} {17}
-test listbox-3.9 {ListboxWidgetCmd procedure, "bbox" option} {
- list [catch {.l bbox} msg] $msg
-} {1 {wrong # args: should be ".l bbox index"}}
-test listbox-3.10 {ListboxWidgetCmd procedure, "bbox" option} {
- list [catch {.l bbox a b} msg] $msg
-} {1 {wrong # args: should be ".l bbox index"}}
-test listbox-3.11 {ListboxWidgetCmd procedure, "bbox" option} {
- list [catch {.l bbox fooey} msg] $msg
-} {1 {bad listbox index "fooey": must be active, anchor, end, @x,y, or a number}}
-test listbox-3.12 {ListboxWidgetCmd procedure, "bbox" option} {
+} -result {17}
+test listbox-3.9 {ListboxWidgetCmd procedure, "bbox" option} -body {
+ .l bbox
+} -returnCodes error -result {wrong # args: should be ".l bbox index"}
+test listbox-3.10 {ListboxWidgetCmd procedure, "bbox" option} -body {
+ .l bbox a b
+} -returnCodes error -result {wrong # args: should be ".l bbox index"}
+test listbox-3.11 {ListboxWidgetCmd procedure, "bbox" option} -body {
+ .l bbox fooey
+} -returnCodes error -result {bad listbox index "fooey": must be active, anchor, end, @x,y, or a number}
+test listbox-3.12 {ListboxWidgetCmd procedure, "bbox" option} -body {
.l yview 3
update
list [.l bbox 2] [.l bbox 8]
-} {{} {}}
-test listbox-3.13 {ListboxWidgetCmd procedure, "bbox" option} {
+} -result {{} {}}
+test listbox-3.13 {ListboxWidgetCmd procedure, "bbox" option} -cleanup {
+ destroy .l2
+} -body {
# Used to generate a core dump before a bug was fixed (the last
# element would be on-screen if it existed, but it doesn't exist).
@@ -190,24 +395,35 @@ test listbox-3.13 {ListboxWidgetCmd procedure, "bbox" option} {
set x [.l2 bbox 0]
destroy .l2
set x
-} {}
-test listbox-3.14 {ListboxWidgetCmd procedure, "bbox" option} {fonts} {
+} -cleanup {
+ destroy .l2
+} -result {}
+test listbox-3.14 {ListboxWidgetCmd procedure, "bbox" option} -constraints {
+ fonts
+} -body {
.l yview 3
update
list [.l bbox 3] [.l bbox 4]
-} {{7 7 17 14} {7 26 17 14}}
-test listbox-3.15 {ListboxWidgetCmd procedure, "bbox" option} {fonts} {
+} -result {{7 7 17 14} {7 26 17 14}}
+test listbox-3.15 {ListboxWidgetCmd procedure, "bbox" option} -constraints {
+ fonts
+} -body {
.l yview 0
update
list [.l bbox -1] [.l bbox 0]
-} {{} {7 7 17 14}}
-test listbox-3.16 {ListboxWidgetCmd procedure, "bbox" option} {fonts} {
+} -result {{} {7 7 17 14}}
+test listbox-3.16 {ListboxWidgetCmd procedure, "bbox" option} -constraints {
+ fonts
+} -body {
.l yview end
update
list [.l bbox 17] [.l bbox end] [.l bbox 18]
-} {{7 83 24 14} {7 83 24 14} {}}
-test listbox-3.17 {ListboxWidgetCmd procedure, "bbox" option} {fonts} {
- catch {destroy .t}
+} -result {{7 83 24 14} {7 83 24 14} {}}
+test listbox-3.17 {ListboxWidgetCmd procedure, "bbox" option} -constraints {
+ fonts
+} -setup {
+ destroy .t
+} -body {
toplevel .t
wm geom .t +0+0
listbox .t.l -width 10 -height 5
@@ -216,255 +432,307 @@ test listbox-3.17 {ListboxWidgetCmd procedure, "bbox" option} {fonts} {
update
.t.l xview moveto .2
.t.l bbox 2
-} {-72 39 393 14}
-test listbox-3.18 {ListboxWidgetCmd procedure, "bbox" option, partial last line} {fonts} {
+} -cleanup {
+ destroy .t
+} -result {-72 39 393 14}
+test listbox-3.18 {ListboxWidgetCmd procedure, "bbox" option, partial last line} -constraints {
+ fonts
+} -body {
mkPartial
list [.partial.l bbox 3] [.partial.l bbox 4]
-} {{5 56 24 14} {5 73 23 14}}
-test listbox-3.19 {ListboxWidgetCmd procedure, "cget" option} {
- list [catch {.l cget} msg] $msg
-} {1 {wrong # args: should be ".l cget option"}}
-test listbox-3.20 {ListboxWidgetCmd procedure, "cget" option} {
- list [catch {.l cget a b} msg] $msg
-} {1 {wrong # args: should be ".l cget option"}}
-test listbox-3.21 {ListboxWidgetCmd procedure, "cget" option} {
- list [catch {.l cget -gorp} msg] $msg
-} {1 {unknown option "-gorp"}}
-test listbox-3.22 {ListboxWidgetCmd procedure, "cget" option} {
+} -result {{5 56 24 14} {5 73 23 14}}
+test listbox-3.19 {ListboxWidgetCmd procedure, "cget" option} -body {
+ .l cget
+} -returnCodes error -result {wrong # args: should be ".l cget option"}
+test listbox-3.20 {ListboxWidgetCmd procedure, "cget" option} -body {
+ .l cget a b
+} -returnCodes error -result {wrong # args: should be ".l cget option"}
+test listbox-3.21 {ListboxWidgetCmd procedure, "cget" option} -body {
+ .l cget -gorp
+} -returnCodes error -result {unknown option "-gorp"}
+test listbox-3.22 {ListboxWidgetCmd procedure, "cget" option} -body {
.l cget -setgrid
-} {0}
-test listbox-3.23 {ListboxWidgetCmd procedure, "configure" option} {
+} -result {0}
+test listbox-3.23 {ListboxWidgetCmd procedure, "configure" option} -body {
llength [.l configure]
-} {27}
-test listbox-3.24 {ListboxWidgetCmd procedure, "configure" option} {
- list [catch {.l configure -gorp} msg] $msg
-} {1 {unknown option "-gorp"}}
-test listbox-3.25 {ListboxWidgetCmd procedure, "configure" option} {
+} -result {27}
+test listbox-3.24 {ListboxWidgetCmd procedure, "configure" option} -body {
+ .l configure -gorp
+} -returnCodes error -result {unknown option "-gorp"}
+test listbox-3.25 {ListboxWidgetCmd procedure, "configure" option} -body {
.l configure -setgrid
-} {-setgrid setGrid SetGrid 0 0}
-test listbox-3.26 {ListboxWidgetCmd procedure, "configure" option} {
- list [catch {.l configure -gorp is_messy} msg] $msg
-} {1 {unknown option "-gorp"}}
-test listbox-3.27 {ListboxWidgetCmd procedure, "configure" option} {
+} -result {-setgrid setGrid SetGrid 0 0}
+test listbox-3.26 {ListboxWidgetCmd procedure, "configure" option} -body {
+ .l configure -gorp is_messy
+} -returnCodes error -result {unknown option "-gorp"}
+test listbox-3.27 {ListboxWidgetCmd procedure, "configure" option} -body {
set oldbd [.l cget -bd]
set oldht [.l cget -highlightthickness]
.l configure -bd 3 -highlightthickness 0
set x "[.l cget -bd] [.l cget -highlightthickness]"
.l configure -bd $oldbd -highlightthickness $oldht
set x
-} {3 0}
-test listbox-3.28 {ListboxWidgetCmd procedure, "curselection" option} {
- list [catch {.l curselection a} msg] $msg
-} {1 {wrong # args: should be ".l curselection"}}
-test listbox-3.29 {ListboxWidgetCmd procedure, "curselection" option} {
+} -result {3 0}
+test listbox-3.28 {ListboxWidgetCmd procedure, "curselection" option} -body {
+ .l curselection a
+} -returnCodes error -result {wrong # args: should be ".l curselection"}
+test listbox-3.29 {ListboxWidgetCmd procedure, "curselection" option} -body {
.l selection clear 0 end
.l selection set 3 6
.l selection set 9
.l curselection
-} {3 4 5 6 9}
-test listbox-3.30 {ListboxWidgetCmd procedure, "delete" option} {
- list [catch {.l delete} msg] $msg
-} {1 {wrong # args: should be ".l delete firstIndex ?lastIndex?"}}
-test listbox-3.31 {ListboxWidgetCmd procedure, "delete" option} {
- list [catch {.l delete a b c} msg] $msg
-} {1 {wrong # args: should be ".l delete firstIndex ?lastIndex?"}}
-test listbox-3.32 {ListboxWidgetCmd procedure, "delete" option} {
- list [catch {.l delete badIndex} msg] $msg
-} {1 {bad listbox index "badIndex": must be active, anchor, end, @x,y, or a number}}
-test listbox-3.33 {ListboxWidgetCmd procedure, "delete" option} {
- list [catch {.l delete 2 123ab} msg] $msg
-} {1 {bad listbox index "123ab": must be active, anchor, end, @x,y, or a number}}
-test listbox-3.34 {ListboxWidgetCmd procedure, "delete" option} {
- catch {destroy .l2}
+} -result {3 4 5 6 9}
+test listbox-3.30 {ListboxWidgetCmd procedure, "delete" option} -body {
+ .l delete
+} -returnCodes error -result {wrong # args: should be ".l delete firstIndex ?lastIndex?"}
+test listbox-3.31 {ListboxWidgetCmd procedure, "delete" option} -body {
+ .l delete a b c
+} -returnCodes error -result {wrong # args: should be ".l delete firstIndex ?lastIndex?"}
+test listbox-3.32 {ListboxWidgetCmd procedure, "delete" option} -body {
+ .l delete badIndex
+} -returnCodes error -result {bad listbox index "badIndex": must be active, anchor, end, @x,y, or a number}
+test listbox-3.33 {ListboxWidgetCmd procedure, "delete" option} -body {
+ .l delete 2 123ab
+} -returnCodes error -result {bad listbox index "123ab": must be active, anchor, end, @x,y, or a number}
+test listbox-3.34 {ListboxWidgetCmd procedure, "delete" option} -setup {
+ destroy .l2
+} -body {
listbox .l2
.l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7
.l2 delete 3
list [.l2 get 2] [.l2 get 3] [.l2 index end]
-} {el2 el4 7}
-test listbox-3.35 {ListboxWidgetCmd procedure, "delete" option} {
- catch {destroy .l2}
+} -cleanup {
+ destroy .l2
+} -result {el2 el4 7}
+test listbox-3.35 {ListboxWidgetCmd procedure, "delete" option} -setup {
+ destroy .l2
+} -body {
listbox .l2
.l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7
.l2 delete 2 4
list [.l2 get 1] [.l2 get 2] [.l2 index end]
-} {el1 el5 5}
-test listbox-3.36 {ListboxWidgetCmd procedure, "delete" option} {
- catch {destroy .l2}
+} -cleanup {
+ destroy .l2
+} -result {el1 el5 5}
+test listbox-3.36 {ListboxWidgetCmd procedure, "delete" option} -setup {
+ destroy .l2
+} -body {
listbox .l2
.l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7
.l2 delete -3 2
.l2 get 0 end
-} {el3 el4 el5 el6 el7}
-test listbox-3.37 {ListboxWidgetCmd procedure, "delete" option} {
- catch {destroy .l2}
+} -cleanup {
+ destroy .l2
+} -result {el3 el4 el5 el6 el7}
+test listbox-3.37 {ListboxWidgetCmd procedure, "delete" option} -setup {
+ destroy .l2
+} -body {
listbox .l2
.l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7
.l2 delete -3 -1
.l2 get 0 end
-} {el0 el1 el2 el3 el4 el5 el6 el7}
-test listbox-3.38 {ListboxWidgetCmd procedure, "delete" option} {
- catch {destroy .l2}
+} -cleanup {
+ destroy .l2
+} -result {el0 el1 el2 el3 el4 el5 el6 el7}
+test listbox-3.38 {ListboxWidgetCmd procedure, "delete" option} -setup {
+ destroy .l2
+} -body {
listbox .l2
.l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7
.l2 delete 2 end
.l2 get 0 end
-} {el0 el1}
-test listbox-3.39 {ListboxWidgetCmd procedure, "delete" option} {
- catch {destroy .l2}
+} -cleanup {
+ destroy .l2
+} -result {el0 el1}
+test listbox-3.39 {ListboxWidgetCmd procedure, "delete" option} -setup {
+ destroy .l2
+} -body {
listbox .l2
.l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7
.l2 delete 5 20
.l2 get 0 end
-} {el0 el1 el2 el3 el4}
-test listbox-3.40 {ListboxWidgetCmd procedure, "delete" option} {
- catch {destroy .l2}
+} -cleanup {
+ destroy .l2
+} -result {el0 el1 el2 el3 el4}
+test listbox-3.40 {ListboxWidgetCmd procedure, "delete" option} -setup {
+ destroy .l2
+} -body {
listbox .l2
.l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7
.l2 delete end 20
.l2 get 0 end
-} {el0 el1 el2 el3 el4 el5 el6}
-test listbox-3.41 {ListboxWidgetCmd procedure, "delete" option} {
- catch {destroy .l2}
+} -cleanup {
+ destroy .l2
+} -result {el0 el1 el2 el3 el4 el5 el6}
+test listbox-3.41 {ListboxWidgetCmd procedure, "delete" option} -setup {
+ destroy .l2
+} -body {
listbox .l2
.l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7
.l2 delete 8 20
.l2 get 0 end
-} {el0 el1 el2 el3 el4 el5 el6 el7}
-test listbox-3.42 {ListboxWidgetCmd procedure, "get" option} {
- list [catch {.l get} msg] $msg
-} {1 {wrong # args: should be ".l get firstIndex ?lastIndex?"}}
-test listbox-3.43 {ListboxWidgetCmd procedure, "get" option} {
- list [catch {.l get a b c} msg] $msg
-} {1 {wrong # args: should be ".l get firstIndex ?lastIndex?"}}
-test listbox-3.44 {ListboxWidgetCmd procedure, "get" option} {
- list [catch {.l get 2.4} msg] $msg
-} {1 {bad listbox index "2.4": must be active, anchor, end, @x,y, or a number}}
-test listbox-3.45 {ListboxWidgetCmd procedure, "get" option} {
- list [catch {.l get end bogus} msg] $msg
-} {1 {bad listbox index "bogus": must be active, anchor, end, @x,y, or a number}}
-test listbox-3.46 {ListboxWidgetCmd procedure, "get" option} {
- catch {destroy .l2}
+} -cleanup {
+ destroy .l2
+} -result {el0 el1 el2 el3 el4 el5 el6 el7}
+test listbox-3.42 {ListboxWidgetCmd procedure, "get" option} -body {
+ .l get
+} -returnCodes error -result {wrong # args: should be ".l get firstIndex ?lastIndex?"}
+test listbox-3.43 {ListboxWidgetCmd procedure, "get" option} -body {
+ .l get a b c
+} -returnCodes error -result {wrong # args: should be ".l get firstIndex ?lastIndex?"}
+test listbox-3.44 {ListboxWidgetCmd procedure, "get" option} -body {
+ .l get 2.4
+} -returnCodes error -result {bad listbox index "2.4": must be active, anchor, end, @x,y, or a number}
+test listbox-3.45 {ListboxWidgetCmd procedure, "get" option} -body {
+ .l get end bogus
+} -returnCodes error -result {bad listbox index "bogus": must be active, anchor, end, @x,y, or a number}
+test listbox-3.46 {ListboxWidgetCmd procedure, "get" option} -setup {
+ destroy .l2
+} -body {
listbox .l2
.l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7
list [.l2 get 0] [.l2 get 3] [.l2 get end]
-} {el0 el3 el7}
-test listbox-3.47 {ListboxWidgetCmd procedure, "get" option} {
- catch {destroy .l2}
+} -cleanup {
+ destroy .l2
+} -result {el0 el3 el7}
+test listbox-3.47 {ListboxWidgetCmd procedure, "get" option} -setup {
+ destroy .l2
+} -body {
listbox .l2
list [.l2 get 0] [.l2 get end]
-} {{} {}}
-test listbox-3.48 {ListboxWidgetCmd procedure, "get" option} {
- catch {destroy .l2}
+} -cleanup {
+ destroy .l2
+} -result {{} {}}
+test listbox-3.48 {ListboxWidgetCmd procedure, "get" option} -setup {
+ destroy .l2
+} -body {
listbox .l2
.l2 insert 0 el0 el1 el2 "two words" el4 el5 el6 el7
.l2 get 3 end
-} {{two words} el4 el5 el6 el7}
-test listbox-3.49 {ListboxWidgetCmd procedure, "get" option} {
+} -cleanup {
+ destroy .l2
+} -result {{two words} el4 el5 el6 el7}
+test listbox-3.49 {ListboxWidgetCmd procedure, "get" option} -body {
.l get -1
-} {}
-test listbox-3.50 {ListboxWidgetCmd procedure, "get" option} {
+} -result {}
+test listbox-3.50 {ListboxWidgetCmd procedure, "get" option} -body {
.l get -2 -1
-} {}
-test listbox-3.51 {ListboxWidgetCmd procedure, "get" option} {
+} -result {}
+test listbox-3.51 {ListboxWidgetCmd procedure, "get" option} -body {
.l get -2 3
-} {el0 el1 el2 el3}
-test listbox-3.52 {ListboxWidgetCmd procedure, "get" option} {
+} -result {el0 el1 el2 el3}
+test listbox-3.52 {ListboxWidgetCmd procedure, "get" option} -body {
.l get 12 end
-} {el12 el13 el14 el15 el16 el17}
-test listbox-3.53 {ListboxWidgetCmd procedure, "get" option} {
+} -result {el12 el13 el14 el15 el16 el17}
+test listbox-3.53 {ListboxWidgetCmd procedure, "get" option} -body {
.l get 12 20
-} {el12 el13 el14 el15 el16 el17}
-test listbox-3.54 {ListboxWidgetCmd procedure, "get" option} {
+} -result {el12 el13 el14 el15 el16 el17}
+test listbox-3.54 {ListboxWidgetCmd procedure, "get" option} -body {
.l get end
-} {el17}
-test listbox-3.55 {ListboxWidgetCmd procedure, "get" option} {
+} -result {el17}
+test listbox-3.55 {ListboxWidgetCmd procedure, "get" option} -body {
.l get 30
-} {}
-test listbox-3.56 {ListboxWidgetCmd procedure, "get" option} {
+} -result {}
+test listbox-3.56 {ListboxWidgetCmd procedure, "get" option} -body {
.l get 30 35
-} {}
-test listbox-3.57 {ListboxWidgetCmd procedure, "index" option} {
- list [catch {.l index} msg] $msg
-} {1 {wrong # args: should be ".l index index"}}
-test listbox-3.58 {ListboxWidgetCmd procedure, "index" option} {
- list [catch {.l index a b} msg] $msg
-} {1 {wrong # args: should be ".l index index"}}
-test listbox-3.59 {ListboxWidgetCmd procedure, "index" option} {
- list [catch {.l index @} msg] $msg
-} {1 {bad listbox index "@": must be active, anchor, end, @x,y, or a number}}
-test listbox-3.60 {ListboxWidgetCmd procedure, "index" option} {
+} -result {}
+test listbox-3.57 {ListboxWidgetCmd procedure, "index" option} -body {
+ .l index
+} -returnCodes error -result {wrong # args: should be ".l index index"}
+test listbox-3.58 {ListboxWidgetCmd procedure, "index" option} -body {
+ .l index a b
+} -returnCodes error -result {wrong # args: should be ".l index index"}
+test listbox-3.59 {ListboxWidgetCmd procedure, "index" option} -body {
+ .l index @
+} -returnCodes error -result {bad listbox index "@": must be active, anchor, end, @x,y, or a number}
+test listbox-3.60 {ListboxWidgetCmd procedure, "index" option} -body {
.l index 2
-} 2
-test listbox-3.61 {ListboxWidgetCmd procedure, "index" option} {
+} -result 2
+test listbox-3.61 {ListboxWidgetCmd procedure, "index" option} -body {
.l index -1
-} -1
-test listbox-3.62 {ListboxWidgetCmd procedure, "index" option} {
+} -result {-1}
+test listbox-3.62 {ListboxWidgetCmd procedure, "index" option} -body {
.l index end
-} 18
-test listbox-3.63 {ListboxWidgetCmd procedure, "index" option} {
+} -result 18
+test listbox-3.63 {ListboxWidgetCmd procedure, "index" option} -body {
.l index 34
-} 34
-test listbox-3.64 {ListboxWidgetCmd procedure, "insert" option} {
- list [catch {.l insert} msg] $msg
-} {1 {wrong # args: should be ".l insert index ?element element ...?"}}
-test listbox-3.65 {ListboxWidgetCmd procedure, "insert" option} {
- list [catch {.l insert badIndex} msg] $msg
-} {1 {bad listbox index "badIndex": must be active, anchor, end, @x,y, or a number}}
-test listbox-3.66 {ListboxWidgetCmd procedure, "insert" option} {
- catch {destroy .l2}
+} -result 34
+test listbox-3.64 {ListboxWidgetCmd procedure, "insert" option} -body {
+ .l insert
+} -returnCodes error -result {wrong # args: should be ".l insert index ?element ...?"}
+test listbox-3.65 {ListboxWidgetCmd procedure, "insert" option} -body {
+ .l insert badIndex
+} -returnCodes error -result {bad listbox index "badIndex": must be active, anchor, end, @x,y, or a number}
+test listbox-3.66 {ListboxWidgetCmd procedure, "insert" option} -setup {
+ destroy .l2
+} -body {
listbox .l2
.l2 insert end a b c d e
.l2 insert 3 x y z
.l2 get 0 end
-} {a b c x y z d e}
-test listbox-3.67 {ListboxWidgetCmd procedure, "insert" option} {
- catch {destroy .l2}
+} -cleanup {
+ destroy .l2
+} -result {a b c x y z d e}
+test listbox-3.67 {ListboxWidgetCmd procedure, "insert" option} -setup {
+ destroy .l2
+} -body {
listbox .l2
.l2 insert end a b c
.l2 insert -1 x
.l2 get 0 end
-} {x a b c}
-test listbox-3.68 {ListboxWidgetCmd procedure, "insert" option} {
- catch {destroy .l2}
+} -cleanup {
+ destroy .l2
+} -result {x a b c}
+test listbox-3.68 {ListboxWidgetCmd procedure, "insert" option} -setup {
+ destroy .l2
+} -body {
listbox .l2
.l2 insert end a b c
.l2 insert end x
.l2 get 0 end
-} {a b c x}
-test listbox-3.69 {ListboxWidgetCmd procedure, "insert" option} {
- catch {destroy .l2}
+} -cleanup {
+ destroy .l2
+} -result {a b c x}
+test listbox-3.69 {ListboxWidgetCmd procedure, "insert" option} -setup {
+ destroy .l2
+} -body {
listbox .l2
.l2 insert end a b c
.l2 insert 43 x
.l2 get 0 end
-} {a b c x}
-test listbox-3.70 {ListboxWidgetCmd procedure, "nearest" option} {
- list [catch {.l nearest} msg] $msg
-} {1 {wrong # args: should be ".l nearest y"}}
-test listbox-3.71 {ListboxWidgetCmd procedure, "nearest" option} {
- list [catch {.l nearest a b} msg] $msg
-} {1 {wrong # args: should be ".l nearest y"}}
-test listbox-3.72 {ListboxWidgetCmd procedure, "nearest" option} {
- list [catch {.l nearest 20p} msg] $msg
-} {1 {expected integer but got "20p"}}
-test listbox-3.73 {ListboxWidgetCmd procedure, "nearest" option} {
+} -cleanup {
+ destroy .l2
+} -result {a b c x}
+test listbox-3.70 {ListboxWidgetCmd procedure, "nearest" option} -body {
+ .l nearest
+} -returnCodes error -result {wrong # args: should be ".l nearest y"}
+test listbox-3.71 {ListboxWidgetCmd procedure, "nearest" option} -body {
+ .l nearest a b
+} -returnCodes error -result {wrong # args: should be ".l nearest y"}
+test listbox-3.72 {ListboxWidgetCmd procedure, "nearest" option} -body {
+ .l nearest 20p
+} -returnCodes error -result {expected integer but got "20p"}
+test listbox-3.73 {ListboxWidgetCmd procedure, "nearest" option} -body {
.l yview 3
.l nearest 1000
-} {7}
-test listbox-3.74 {ListboxWidgetCmd procedure, "scan" option} {
- list [catch {.l scan a b} msg] $msg
-} {1 {wrong # args: should be ".l scan mark|dragto x y"}}
-test listbox-3.75 {ListboxWidgetCmd procedure, "scan" option} {
- list [catch {.l scan a b c d} msg] $msg
-} {1 {wrong # args: should be ".l scan mark|dragto x y"}}
-test listbox-3.76 {ListboxWidgetCmd procedure, "scan" option} {
- list [catch {.l scan foo bogus 2} msg] $msg
-} {1 {expected integer but got "bogus"}}
-test listbox-3.77 {ListboxWidgetCmd procedure, "scan" option} {
- list [catch {.l scan foo 2 2.3} msg] $msg
-} {1 {expected integer but got "2.3"}}
-test listbox-3.78 {ListboxWidgetCmd procedure, "scan" option} {fonts} {
- catch {destroy .t}
+} -result {7}
+test listbox-3.74 {ListboxWidgetCmd procedure, "scan" option} -body {
+ .l scan a b
+} -returnCodes error -result {wrong # args: should be ".l scan mark|dragto x y"}
+test listbox-3.75 {ListboxWidgetCmd procedure, "scan" option} -body {
+ .l scan a b c d
+} -returnCodes error -result {wrong # args: should be ".l scan mark|dragto x y"}
+test listbox-3.76 {ListboxWidgetCmd procedure, "scan" option} -body {
+ .l scan foo bogus 2
+} -returnCodes error -result {expected integer but got "bogus"}
+test listbox-3.77 {ListboxWidgetCmd procedure, "scan" option} -body {
+ .l scan foo 2 2.3
+} -returnCodes error -result {expected integer but got "2.3"}
+test listbox-3.78 {ListboxWidgetCmd procedure, "scan" option} -constraints {
+ fonts
+} -setup {
+ destroy .t
+} -body {
toplevel .t
wm geom .t +0+0
listbox .t.l -width 10 -height 5
@@ -475,312 +743,461 @@ test listbox-3.78 {ListboxWidgetCmd procedure, "scan" option} {fonts} {
.t.l scan dragto 90 137
update
list [format {%.6g %.6g} {*}[.t.l xview]] [format {%.6g %.6g} {*}[.t.l yview]]
-} {{0.249364 0.427481} {0.0714286 0.428571}}
-test listbox-3.79 {ListboxWidgetCmd procedure, "scan" option} {
- list [catch {.l scan foo 2 4} msg] $msg
-} {1 {bad option "foo": must be mark or dragto}}
-test listbox-3.80 {ListboxWidgetCmd procedure, "see" option} {
- list [catch {.l see} msg] $msg
-} {1 {wrong # args: should be ".l see index"}}
-test listbox-3.81 {ListboxWidgetCmd procedure, "see" option} {
- list [catch {.l see a b} msg] $msg
-} {1 {wrong # args: should be ".l see index"}}
-test listbox-3.82 {ListboxWidgetCmd procedure, "see" option} {
- list [catch {.l see gorp} msg] $msg
-} {1 {bad listbox index "gorp": must be active, anchor, end, @x,y, or a number}}
-test listbox-3.83 {ListboxWidgetCmd procedure, "see" option} {
+} -cleanup {
+ destroy .t
+} -result {{0.249364 0.427481} {0.0714286 0.428571}}
+test listbox-3.79 {ListboxWidgetCmd procedure, "scan" option} -body {
+ .l scan foo 2 4
+} -returnCodes error -result {bad option "foo": must be mark or dragto}
+test listbox-3.80 {ListboxWidgetCmd procedure, "see" option} -body {
+ .l see
+} -returnCodes error -result {wrong # args: should be ".l see index"}
+test listbox-3.81 {ListboxWidgetCmd procedure, "see" option} -body {
+ .l see a b
+} -returnCodes error -result {wrong # args: should be ".l see index"}
+test listbox-3.82 {ListboxWidgetCmd procedure, "see" option} -body {
+ .l see gorp
+} -returnCodes error -result {bad listbox index "gorp": must be active, anchor, end, @x,y, or a number}
+test listbox-3.83 {ListboxWidgetCmd procedure, "see" option} -body {
.l yview 7
.l see 7
.l index @0,0
-} {7}
-test listbox-3.84 {ListboxWidgetCmd procedure, "see" option} {
+} -result {7}
+test listbox-3.84 {ListboxWidgetCmd procedure, "see" option} -body {
.l yview 7
.l see 11
.l index @0,0
-} {7}
-test listbox-3.85 {ListboxWidgetCmd procedure, "see" option} {
+} -result {7}
+test listbox-3.85 {ListboxWidgetCmd procedure, "see" option} -body {
.l yview 7
.l see 6
.l index @0,0
-} {6}
-test listbox-3.86 {ListboxWidgetCmd procedure, "see" option} {
+} -result {6}
+test listbox-3.86 {ListboxWidgetCmd procedure, "see" option} -body {
.l yview 7
.l see 5
.l index @0,0
-} {3}
-test listbox-3.87 {ListboxWidgetCmd procedure, "see" option} {
+} -result {3}
+test listbox-3.87 {ListboxWidgetCmd procedure, "see" option} -body {
.l yview 7
.l see 12
.l index @0,0
-} {8}
-test listbox-3.88 {ListboxWidgetCmd procedure, "see" option} {
+} -result {8}
+test listbox-3.88 {ListboxWidgetCmd procedure, "see" option} -body {
.l yview 7
.l see 13
.l index @0,0
-} {11}
-test listbox-3.89 {ListboxWidgetCmd procedure, "see" option} {
+} -result {11}
+test listbox-3.89 {ListboxWidgetCmd procedure, "see" option} -body {
.l yview 7
.l see -1
.l index @0,0
-} {0}
-test listbox-3.90 {ListboxWidgetCmd procedure, "see" option} {
+} -result {0}
+test listbox-3.90 {ListboxWidgetCmd procedure, "see" option} -body {
.l yview 7
.l see end
.l index @0,0
-} {13}
-test listbox-3.91 {ListboxWidgetCmd procedure, "see" option} {
+} -result {13}
+test listbox-3.91 {ListboxWidgetCmd procedure, "see" option} -body {
.l yview 7
.l see 322
.l index @0,0
-} {13}
-test listbox-3.92 {ListboxWidgetCmd procedure, "see" option, partial last line} {
+} -result {13}
+test listbox-3.92 {ListboxWidgetCmd procedure, "see" option, partial last line} -body {
mkPartial
.partial.l see 4
.partial.l index @0,0
-} {1}
-test listbox-3.93 {ListboxWidgetCmd procedure, "selection" option} {
- list [catch {.l select a} msg] $msg
-} {1 {wrong # args: should be ".l selection option index ?index?"}}
-test listbox-3.94 {ListboxWidgetCmd procedure, "selection" option} {
- list [catch {.l select a b c d} msg] $msg
-} {1 {wrong # args: should be ".l selection option index ?index?"}}
-test listbox-3.95 {ListboxWidgetCmd procedure, "selection" option} {
- list [catch {.l selection a bogus} msg] $msg
-} {1 {bad listbox index "bogus": must be active, anchor, end, @x,y, or a number}}
-test listbox-3.96 {ListboxWidgetCmd procedure, "selection" option} {
- list [catch {.l selection a 0 lousy} msg] $msg
-} {1 {bad listbox index "lousy": must be active, anchor, end, @x,y, or a number}}
-test listbox-3.97 {ListboxWidgetCmd procedure, "selection" option} {
- list [catch {.l selection anchor 0 0} msg] $msg
-} {1 {wrong # args: should be ".l selection anchor index"}}
-test listbox-3.98 {ListboxWidgetCmd procedure, "selection" option} {
+} -result {1}
+test listbox-3.93 {ListboxWidgetCmd procedure, "selection" option} -body {
+ .l select a
+} -returnCodes error -result {wrong # args: should be ".l selection option index ?index?"}
+test listbox-3.94 {ListboxWidgetCmd procedure, "selection" option} -body {
+ .l select a b c d
+} -returnCodes error -result {wrong # args: should be ".l selection option index ?index?"}
+test listbox-3.95 {ListboxWidgetCmd procedure, "selection" option} -body {
+ .l selection a bogus
+} -returnCodes error -result {bad listbox index "bogus": must be active, anchor, end, @x,y, or a number}
+test listbox-3.96 {ListboxWidgetCmd procedure, "selection" option} -body {
+ .l selection a 0 lousy
+} -returnCodes error -result {bad listbox index "lousy": must be active, anchor, end, @x,y, or a number}
+test listbox-3.97 {ListboxWidgetCmd procedure, "selection" option} -body {
+ .l selection anchor 0 0
+} -returnCodes error -result {wrong # args: should be ".l selection anchor index"}
+test listbox-3.98 {ListboxWidgetCmd procedure, "selection" option} -body {
list [.l selection anchor 5; .l index anchor] \
[.l selection anchor 0; .l index anchor]
-} {5 0}
-test listbox-3.99 {ListboxWidgetCmd procedure, "selection" option} {
+} -result {5 0}
+test listbox-3.99 {ListboxWidgetCmd procedure, "selection" option} -body {
.l selection anchor -1
.l index anchor
-} {0}
-test listbox-3.100 {ListboxWidgetCmd procedure, "selection" option} {
+} -result {0}
+test listbox-3.100 {ListboxWidgetCmd procedure, "selection" option} -body {
.l selection anchor end
.l index anchor
-} {17}
-test listbox-3.101 {ListboxWidgetCmd procedure, "selection" option} {
+} -result {17}
+test listbox-3.101 {ListboxWidgetCmd procedure, "selection" option} -body {
.l selection anchor 44
.l index anchor
-} {17}
-test listbox-3.102 {ListboxWidgetCmd procedure, "selection" option} {
+} -result {17}
+test listbox-3.102 {ListboxWidgetCmd procedure, "selection" option} -body {
.l selection clear 0 end
.l selection set 2 8
.l selection clear 3 4
.l curselection
-} {2 5 6 7 8}
-test listbox-3.103 {ListboxWidgetCmd procedure, "selection" option} {
- list [catch {.l selection includes 0 0} msg] $msg
-} {1 {wrong # args: should be ".l selection includes index"}}
-test listbox-3.104 {ListboxWidgetCmd procedure, "selection" option} {
+} -result {2 5 6 7 8}
+test listbox-3.103 {ListboxWidgetCmd procedure, "selection" option} -body {
+ .l selection includes 0 0
+} -returnCodes error -result {wrong # args: should be ".l selection includes index"}
+test listbox-3.104 {ListboxWidgetCmd procedure, "selection" option} -body {
.l selection clear 0 end
.l selection set 2 8
.l selection clear 4
list [.l selection includes 3] [.l selection includes 4] \
[.l selection includes 5]
-} {1 0 1}
-test listbox-3.105 {ListboxWidgetCmd procedure, "selection" option} {
+} -result {1 0 1}
+test listbox-3.105 {ListboxWidgetCmd procedure, "selection" option} -body {
.l selection set 0 end
.l selection includes -1
-} {0}
-test listbox-3.106 {ListboxWidgetCmd procedure, "selection" option} {
+} -result {0}
+test listbox-3.106 {ListboxWidgetCmd procedure, "selection" option} -body {
.l selection clear 0 end
.l selection set end
.l selection includes end
-} {1}
-test listbox-3.107 {ListboxWidgetCmd procedure, "selection" option} {
+} -result {1}
+test listbox-3.107 {ListboxWidgetCmd procedure, "selection" option} -body {
.l selection set 0 end
.l selection includes 44
-} {0}
-test listbox-3.108 {ListboxWidgetCmd procedure, "selection" option} {
- catch {destroy .l2}
+} -result {0}
+test listbox-3.108 {ListboxWidgetCmd procedure, "selection" option} -setup {
+ destroy .l2
+} -body {
listbox .l2
.l2 selection includes 0
-} {0}
-test listbox-3.109 {ListboxWidgetCmd procedure, "selection" option} {
+} -cleanup {
+ destroy .l2
+} -result {0}
+test listbox-3.109 {ListboxWidgetCmd procedure, "selection" option} -body {
.l selection clear 0 end
.l selection set 2
.l selection set 5 7
.l curselection
-} {2 5 6 7}
-test listbox-3.110 {ListboxWidgetCmd procedure, "selection" option} {
+} -result {2 5 6 7}
+test listbox-3.110 {ListboxWidgetCmd procedure, "selection" option} -body {
+ .l selection clear 0 end
+ .l selection set 2
+ .l selection set 5 7
.l selection set 5 7
.l curselection
-} {2 5 6 7}
-test listbox-3.111 {ListboxWidgetCmd procedure, "selection" option} {
- list [catch {.l selection badOption 0 0} msg] $msg
-} {1 {bad option "badOption": must be anchor, clear, includes, or set}}
-test listbox-3.112 {ListboxWidgetCmd procedure, "size" option} {
- list [catch {.l size a} msg] $msg
-} {1 {wrong # args: should be ".l size"}}
-test listbox-3.113 {ListboxWidgetCmd procedure, "size" option} {
+} -result {2 5 6 7}
+test listbox-3.111 {ListboxWidgetCmd procedure, "selection" option} -body {
+ .l selection badOption 0 0
+} -returnCodes error -result {bad option "badOption": must be anchor, clear, includes, or set}
+test listbox-3.112 {ListboxWidgetCmd procedure, "size" option} -body {
+ .l size a
+} -returnCodes error -result {wrong # args: should be ".l size"}
+test listbox-3.113 {ListboxWidgetCmd procedure, "size" option} -body {
.l size
-} {18}
-test listbox-3.114 {ListboxWidgetCmd procedure, "xview" option} {
- catch {destroy .l2}
+} -result {18}
+test listbox-3.114 {ListboxWidgetCmd procedure, "xview" option} -setup {
+ destroy .l2
+} -body {
listbox .l2
update
format {%.6g %.6g} {*}[.l2 xview]
-} {0 1}
-test listbox-3.115 {ListboxWidgetCmd procedure, "xview" option} {
- catch {destroy .l}
- listbox .l -width 10 -height 5 -font $fixed
- .l insert 0 a b c d e f g h i j k l m n o p q r s t
- pack .l
+} -cleanup {
+ destroy .l2
+} -result {0 1}
+test listbox-3.115 {ListboxWidgetCmd procedure, "xview" option} -setup {
+ destroy .l2
+} -body {
+ listbox .l2 -width 10 -height 5 -font $fixed
+ .l2 insert 0 a b c d e f g h i j k l m n o p q r s t
+ pack .l2
update
- format {%.6g %.6g} {*}[.l xview]
-} {0 1}
-catch {destroy .l}
-listbox .l -width 10 -height 5 -font $fixed
-.l insert 0 a b c d e f g h i j k l m n o p q r s t
-.l insert 1 "0123456789a123456789b123456789c123456789d123456789"
-pack .l
-update
-test listbox-3.116 {ListboxWidgetCmd procedure, "xview" option} {fonts} {
- .l xview 4
- format {%.6g %.6g} {*}[.l xview]
-} {0.08 0.28}
-test listbox-3.117 {ListboxWidgetCmd procedure, "xview" option} {
- list [catch {.l xview foo} msg] $msg
-} {1 {expected integer but got "foo"}}
-test listbox-3.118 {ListboxWidgetCmd procedure, "xview" option} {
- list [catch {.l xview zoom a b} msg] $msg
-} {1 {unknown option "zoom": must be moveto or scroll}}
-test listbox-3.119 {ListboxWidgetCmd procedure, "xview" option} {fonts} {
- .l xview 0
- .l xview moveto .4
+ format {%.6g %.6g} {*}[.l2 xview]
+} -cleanup {
+ destroy .l2
+} -result {0 1}
+
+test listbox-3.116 {ListboxWidgetCmd procedure, "xview" option} -constraints {
+ fonts
+} -setup {
+ destroy .l2
+ listbox .l2 -width 10 -height 5 -font $fixed
+ pack .l2
update
- format {%.6g %.6g} {*}[.l xview]
-} {0.4 0.6}
-test listbox-3.120 {ListboxWidgetCmd procedure, "xview" option} {fonts} {
+} -body {
+ .l2 insert 0 a b c d e f g h i j k l m n o p q r s t
+ .l2 insert 1 "0123456789a123456789b123456789c123456789d123456789"
+ .l2 xview 4
+ format {%.6g %.6g} {*}[.l2 xview]
+} -cleanup {
+ destroy .l2
+} -result {0.08 0.28}
+test listbox-3.117 {ListboxWidgetCmd procedure, "xview" option} -body {
+ .l xview foo
+} -returnCodes error -result {expected integer but got "foo"}
+test listbox-3.118 {ListboxWidgetCmd procedure, "xview" option} -body {
+ .l xview zoom a b
+} -returnCodes error -result {unknown option "zoom": must be moveto or scroll}
+test listbox-3.119 {ListboxWidgetCmd procedure, "xview" option} -constraints {
+ fonts
+} -setup {
+ destroy .l2
+ listbox .l2 -width 10 -height 5 -font $fixed
+ pack .l2
+ update
+} -body {
+ .l2 insert 0 a b c d e f g h i j k l m n o p q r s t
+ .l2 insert 1 "0123456789a123456789b123456789c123456789d123456789"
.l xview 0
- .l xview scroll 2 units
- update
- format {%.6g %.6g} {*}[.l xview]
-} {0.04 0.24}
-test listbox-3.121 {ListboxWidgetCmd procedure, "xview" option} {fonts} {
- .l xview 30
- .l xview scroll -1 pages
- update
- format {%.6g %.6g} {*}[.l xview]
-} {0.44 0.64}
-test listbox-3.122 {ListboxWidgetCmd procedure, "xview" option} {fonts} {
- .l configure -width 1
- update
- .l xview 30
- .l xview scroll -4 pages
- update
- format {%.6g %.6g} {*}[.l xview]
-} {0.52 0.54}
-test listbox-3.123 {ListboxWidgetCmd procedure, "yview" option} {
- catch {destroy .l}
- listbox .l
- pack .l
+ .l2 xview moveto .4
update
- format {%.6g %.6g} {*}[.l yview]
-} {0 1}
-test listbox-3.124 {ListboxWidgetCmd procedure, "yview" option} {
- catch {destroy .l}
- listbox .l
- .l insert 0 el1
- pack .l
+ format {%.6g %.6g} {*}[.l2 xview]
+} -cleanup {
+ destroy .l2
+} -result {0.4 0.6}
+test listbox-3.120 {ListboxWidgetCmd procedure, "xview" option} -constraints {
+ fonts
+} -setup {
+ destroy .l2
+ listbox .l2 -width 10 -height 5 -font $fixed
+ pack .l2
update
- format {%.6g %.6g} {*}[.l yview]
-} {0 1}
-catch {destroy .l}
-listbox .l -width 10 -height 5 -font $fixed
-.l insert 0 a b c d e f g h i j k l m n o p q r s t
-pack .l
-update
-test listbox-3.125 {ListboxWidgetCmd procedure, "yview" option} {
- .l yview 4
+} -body {
+ .l2 insert 0 a b c d e f g h i j k l m n o p q r s t
+ .l2 insert 1 "0123456789a123456789b123456789c123456789d123456789"
+ .l2 xview 0
+ .l2 xview scroll 2 units
+ update
+ format {%.6g %.6g} {*}[.l2 xview]
+} -cleanup {
+ destroy .l2
+} -result {0.04 0.24}
+test listbox-3.121 {ListboxWidgetCmd procedure, "xview" option} -constraints {
+ fonts
+} -setup {
+ destroy .l2
+ listbox .l2 -width 10 -height 5 -font $fixed
+ pack .l2
+ update
+} -body {
+ .l2 insert 0 a b c d e f g h i j k l m n o p q r s t
+ .l2 insert 1 "0123456789a123456789b123456789c123456789d123456789"
+ .l2 xview 30
+ .l2 xview scroll -1 pages
+ update
+ format {%.6g %.6g} {*}[.l2 xview]
+} -cleanup {
+ destroy .l2
+} -result {0.44 0.64}
+test listbox-3.122 {ListboxWidgetCmd procedure, "xview" option} -constraints {
+ fonts
+} -setup {
+ destroy .l2
+ listbox .l2 -width 10 -height 5 -font $fixed
+ pack .l2
update
- format {%.6g %.6g} {*}[.l yview]
-} {0.2 0.45}
-test listbox-3.126 {ListboxWidgetCmd procedure, "yview" option, partial last line} {
+} -body {
+ .l2 insert 0 a b c d e f g h i j k l m n o p q r s t
+ .l2 insert 1 "0123456789a123456789b123456789c123456789d123456789"
+ .l2 configure -width 1
+ update
+ .l2 xview 30
+ .l2 xview scroll -4 pages
+ update
+ format {%.6g %.6g} {*}[.l2 xview]
+} -cleanup {
+ destroy .l2
+} -result {0.52 0.54}
+test listbox-3.123 {ListboxWidgetCmd procedure, "yview" option} -setup {
+ destroy .l2
+} -body {
+ listbox .l2
+ pack .l2
+ update
+ format {%.6g %.6g} {*}[.l2 yview]
+} -cleanup {
+ destroy .l2
+} -result {0 1}
+test listbox-3.124 {ListboxWidgetCmd procedure, "yview" option} -setup {
+ destroy .l2
+} -body {
+ listbox .l2
+ .l2 insert 0 el1
+ pack .l2
+ update
+ format {%.6g %.6g} {*}[.l2 yview]
+} -cleanup {
+ destroy .l2
+} -result {0 1}
+
+test listbox-3.125 {ListboxWidgetCmd procedure, "yview" option} -setup {
+ destroy .l2
+ listbox .l2 -width 10 -height 5 -font $fixed
+ pack .l2
+ update
+} -body {
+ .l2 insert 0 a b c d e f g h i j k l m n o p q r s t
+ .l2 yview 4
+ update
+ format {%.6g %.6g} {*}[.l2 yview]
+} -cleanup {
+ destroy .l2
+} -result {0.2 0.45}
+test listbox-3.126 {ListboxWidgetCmd procedure, "yview" option, partial last line} -setup {
+ destroy .l
+ listbox .l -width 10 -height 5 -font $fixed
+ pack .l
+ update
+} -body {
+ .l insert 0 a b c d e f g h i j k l m n o p q r s t
mkPartial
format {%.6g %.6g} {*}[.partial.l yview]
-} {0 0.266667}
-test listbox-3.127 {ListboxWidgetCmd procedure, "xview" option} {
- list [catch {.l yview foo} msg] $msg
-} {1 {bad listbox index "foo": must be active, anchor, end, @x,y, or a number}}
-test listbox-3.128 {ListboxWidgetCmd procedure, "xview" option} {
- list [catch {.l yview foo a b} msg] $msg
-} {1 {unknown option "foo": must be moveto or scroll}}
-test listbox-3.129 {ListboxWidgetCmd procedure, "xview" option} {
- .l yview 0
- .l yview moveto .31
- format {%.6g %.6g} {*}[.l yview]
-} {0.3 0.55}
-test listbox-3.130 {ListboxWidgetCmd procedure, "xview" option} {
- .l yview 2
- .l yview scroll 2 pages
- format {%.6g %.6g} {*}[.l yview]
-} {0.4 0.65}
-test listbox-3.131 {ListboxWidgetCmd procedure, "xview" option} {
- .l yview 10
- .l yview scroll -3 units
- format {%.6g %.6g} {*}[.l yview]
-} {0.35 0.6}
-test listbox-3.132 {ListboxWidgetCmd procedure, "xview" option} {
- .l configure -height 2
- update
- .l yview 15
- .l yview scroll -4 pages
- format {%.6g %.6g} {*}[.l yview]
-} {0.55 0.65}
-test listbox-3.133 {ListboxWidgetCmd procedure, "xview" option} {
- list [catch {.l whoknows} msg] $msg
-} {1 {bad option "whoknows": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview}}
-test listbox-3.134 {ListboxWidgetCmd procedure, "xview" option} {
- list [catch {.l c} msg] $msg
-} {1 {ambiguous option "c": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview}}
-test listbox-3.135 {ListboxWidgetCmd procedure, "xview" option} {
- list [catch {.l in} msg] $msg
-} {1 {ambiguous option "in": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview}}
-test listbox-3.136 {ListboxWidgetCmd procedure, "xview" option} {
- list [catch {.l s} msg] $msg
-} {1 {ambiguous option "s": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview}}
-test listbox-3.137 {ListboxWidgetCmd procedure, "xview" option} {
- list [catch {.l se} msg] $msg
-} {1 {ambiguous option "se": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview}}
+} -cleanup {
+ destroy .l
+} -result {0 0.266667}
+
+# Listbox used in 3.127 -3.137 tests
+destroy .l
+listbox .l -width 20 -height 5 -bd 4 -highlightthickness 1 -selectborderwidth 2
+pack .l
+.l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 el12 el13 el14 \
+ el15 el16 el17
+update
+test listbox-3.127 {ListboxWidgetCmd procedure, "xview" option} -body {
+ .l yview foo
+} -returnCodes error -result {bad listbox index "foo": must be active, anchor, end, @x,y, or a number}
+test listbox-3.128 {ListboxWidgetCmd procedure, "xview" option} -body {
+ .l yview foo a b
+} -returnCodes error -result {unknown option "foo": must be moveto or scroll}
+test listbox-3.129 {ListboxWidgetCmd procedure, "xview" option} -setup {
+ destroy .l2
+ listbox .l2 -width 10 -height 5 -font $fixed
+ pack .l2
+ update
+} -body {
+ .l2 insert 0 a b c d e f g h i j k l m n o p q r s t
+ .l2 yview 0
+ .l2 yview moveto .31
+ format {%.6g %.6g} {*}[.l2 yview]
+} -cleanup {
+ destroy .l2
+} -result {0.3 0.55}
+test listbox-3.130 {ListboxWidgetCmd procedure, "xview" option} -setup {
+ destroy .l2
+ listbox .l2 -width 10 -height 5 -font $fixed
+ pack .l2
+ update
+} -body {
+ .l2 insert 0 a b c d e f g h i j k l m n o p q r s t
+ .l2 yview 2
+ .l2 yview scroll 2 pages
+ format {%.6g %.6g} {*}[.l2 yview]
+} -cleanup {
+ destroy .l2
+} -result {0.4 0.65}
+test listbox-3.131 {ListboxWidgetCmd procedure, "xview" option} -setup {
+ destroy .l2
+ listbox .l2 -width 10 -height 5 -font $fixed
+ pack .l2
+ update
+} -body {
+ .l2 insert 0 a b c d e f g h i j k l m n o p q r s t
+ .l2 yview 10
+ .l2 yview scroll -3 units
+ format {%.6g %.6g} {*}[.l2 yview]
+} -cleanup {
+ destroy .l2
+} -result {0.35 0.6}
+test listbox-3.132 {ListboxWidgetCmd procedure, "xview" option} -setup {
+ destroy .l2
+ listbox .l2 -width 10 -height 5 -font $fixed
+ pack .l2
+ update
+} -body {
+ .l2 insert 0 a b c d e f g h i j k l m n o p q r s t
+ .l2 configure -height 2
+ update
+ .l2 yview 15
+ .l2 yview scroll -4 pages
+ format {%.6g %.6g} {*}[.l2 yview]
+} -cleanup {
+ destroy .l2
+} -result {0.55 0.65}
+test listbox-3.133 {ListboxWidgetCmd procedure, "xview" option} -body {
+ .l whoknows
+} -returnCodes error -result {bad option "whoknows": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview}
+test listbox-3.134 {ListboxWidgetCmd procedure, "xview" option} -body {
+ .l c
+} -returnCodes error -result {ambiguous option "c": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview}
+test listbox-3.135 {ListboxWidgetCmd procedure, "xview" option} -body {
+ .l in
+} -returnCodes error -result {ambiguous option "in": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview}
+test listbox-3.136 {ListboxWidgetCmd procedure, "xview" option} -body {
+ .l s
+} -returnCodes error -result {ambiguous option "s": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview}
+test listbox-3.137 {ListboxWidgetCmd procedure, "xview" option} -body {
+ .l se
+} -returnCodes error -result {ambiguous option "se": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview}
# No tests for DestroyListbox: I can't come up with anything to test
# in this procedure.
-test listbox-4.1 {ConfigureListbox procedure} {fonts} {
- catch {destroy .l}
+
+test listbox-4.1 {ConfigureListbox procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+ destroy .l
listbox .l -setgrid 1 -width 25 -height 15
pack .l
update
+} -body {
set x [getsize .]
.l configure -setgrid 0
update
list $x [getsize .]
-} {25x15 185x263}
+} -cleanup {
+ deleteWindows
+} -result {25x15 185x263}
resetGridInfo
-test listbox-4.2 {ConfigureListbox procedure} {
+test listbox-4.2 {ConfigureListbox procedure} -setup {
+ deleteWindows
+ destroy .l
+ listbox .l -setgrid 1 -width 25 -height 15
+ pack .l
+ update
+} -body {
.l configure -highlightthickness -3
.l cget -highlightthickness
-} {0}
-test listbox-4.3 {ConfigureListbox procedure} {
+} -cleanup {
+ deleteWindows
+} -result {0}
+test listbox-4.3 {ConfigureListbox procedure} -setup {
+ deleteWindows
+ destroy .l
+ listbox .l -setgrid 1 -width 25 -height 15
+ pack .l
+ update
+} -body {
.l configure -exportselection 0
.l delete 0 end
.l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8
.l selection set 3 5
.l configure -exportselection 1
selection get
-} {el3
+} -cleanup {
+ deleteWindows
+} -result {el3
el4
el5}
-test listbox-4.4 {ConfigureListbox procedure} {
- catch {destroy .e}
+test listbox-4.4 {ConfigureListbox procedure} -setup {
+ deleteWindows
+ listbox .l -setgrid 1 -width 25 -height 15
+ pack .l
+ update
+} -body {
entry .e
.e insert 0 abc
.e select from 0
@@ -792,8 +1209,15 @@ test listbox-4.4 {ConfigureListbox procedure} {
.l selection clear 3 5
.l configure -exportselection 1
list [selection own] [selection get]
-} {.e ab}
-test listbox-4.5 {-exportselection option} {
+} -cleanup {
+ deleteWindows
+} -result {.e ab}
+test listbox-4.5 {-exportselection option} -setup {
+ deleteWindows
+ listbox .l -setgrid 1 -width 25 -height 15
+ pack .l
+ update
+} -body {
selection clear .
.l configure -exportselection 1
.l delete 0 end
@@ -809,11 +1233,16 @@ test listbox-4.5 {-exportselection option} {
lappend x [catch {selection get} msg] $msg [.l curselection]
.l config -exportselection 1
lappend x [catch {selection get} msg] $msg [.l curselection]
-} {0 el1 1 1 {PRIMARY selection doesn't exist or form "STRING" not defined} 1 1 {PRIMARY selection doesn't exist or form "STRING" not defined} {} 1 {PRIMARY selection doesn't exist or form "STRING" not defined} {1 2 3} 0 {el1
+} -cleanup {
+ deleteWindows
+} -result {0 el1 1 1 {PRIMARY selection doesn't exist or form "STRING" not defined} 1 1 {PRIMARY selection doesn't exist or form "STRING" not defined} {} 1 {PRIMARY selection doesn't exist or form "STRING" not defined} {1 2 3} 0 {el1
el2
el3} {1 2 3}}
-test listbox-4.6 {ConfigureListbox procedure} {fonts} {
- catch {destroy .l}
+test listbox-4.6 {ConfigureListbox procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
# The following code (reset geometry, withdraw, etc.) is necessary
# to reset the state of some window managers like olvwm under
@@ -823,246 +1252,307 @@ test listbox-4.6 {ConfigureListbox procedure} {fonts} {
update
wm geom . {}
wm withdraw .
- listbox .l -font $fixed -width 15 -height 20
- pack .l
+ listbox .l2 -font $fixed -width 15 -height 20
+ pack .l2
update
wm deiconify .
set x [getsize .]
- .l configure -setgrid 1
+ .l2 configure -setgrid 1
update
list $x [getsize .]
-} {115x328 15x20}
-test listbox-4.7 {ConfigureListbox procedure} {
- catch {destroy .l}
+} -cleanup {
+ deleteWindows
+} -result {115x328 15x20}
+test listbox-4.7 {ConfigureListbox procedure} -setup {
+ deleteWindows
+} -body {
wm withdraw .
- listbox .l -font $fixed -width 30 -height 20 -setgrid 1
+ listbox .l2 -font $fixed -width 30 -height 20 -setgrid 1
wm geom . +25+25
- pack .l
+ pack .l2
update
wm deiconify .
set result [getsize .]
wm geom . 26x15
update
lappend result [getsize .]
- .l configure -setgrid 1
+ .l2 configure -setgrid 1
update
lappend result [getsize .]
-} {30x20 26x15 26x15}
-wm geom . {}
-catch {destroy .l}
+} -cleanup {
+ deleteWindows
+ wm geom . {}
+} -result {30x20 26x15 26x15}
+
resetGridInfo
-test listbox-4.8 {ConfigureListbox procedure} {
- catch {destroy .l}
- listbox .l -width 15 -height 20 -xscrollcommand "record x" \
+test listbox-4.8 {ConfigureListbox procedure} -setup {
+ destroy .l2
+} -body {
+ listbox .l2 -width 15 -height 20 -xscrollcommand "record x" \
-yscrollcommand "record y"
- pack .l
+ pack .l2
update
- .l configure -fg black
+ .l2 configure -fg black
set log {}
update
set log
-} {{y 0 1} {x 0 1}}
-test listbox-4.9 {ConfigureListbox procedure, -listvar} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l2
+} -result {{y 0 1} {x 0 1}}
+test listbox-4.9 {ConfigureListbox procedure, -listvar} -setup {
+ destroy .l2
+} -body {
set x [list a b c d]
- listbox .l -listvar x
- .l get 0 end
-} [list a b c d]
-test listbox-4.10 {ConfigureListbox, no listvar -> existing listvar} {
- catch {destroy .l}
+ listbox .l2 -listvar x
+ .l2 get 0 end
+} -cleanup {
+ destroy .l2
+} -result [list a b c d]
+test listbox-4.10 {ConfigureListbox, no listvar -> existing listvar} -setup {
+ destroy .l2
+} -body {
set x [list a b c d]
- listbox .l
- .l insert end 1 2 3 4
- .l configure -listvar x
- .l get 0 end
-} [list a b c d]
-test listbox-4.11 {ConfigureListbox procedure, listvar -> no listvar} {
- catch {destroy .l}
+ listbox .l2
+ .l2 insert end 1 2 3 4
+ .l2 configure -listvar x
+ .l2 get 0 end
+} -cleanup {
+ destroy .l2
+} -result [list a b c d]
+test listbox-4.11 {ConfigureListbox procedure, listvar -> no listvar} -setup {
+ destroy .l2
+} -body {
set x [list a b c d]
- listbox .l -listvar x
- .l configure -listvar {}
- .l insert end 1 2 3 4
- list $x [.l get 0 end]
-} [list [list a b c d] [list a b c d 1 2 3 4]]
-test listbox-4.12 {ConfigureListbox procedure, listvar -> different listvar} {
- catch {destroy .l}
+ listbox .l2 -listvar x
+ .l2 configure -listvar {}
+ .l2 insert end 1 2 3 4
+ list $x [.l2 get 0 end]
+} -cleanup {
+ destroy .l2
+} -result [list [list a b c d] [list a b c d 1 2 3 4]]
+test listbox-4.12 {ConfigureListbox procedure, listvar -> different listvar} -setup {
+ destroy .l2
+} -body {
set x [list a b c d]
set y [list 1 2 3 4]
- listbox .l
- .l configure -listvar x
- .l configure -listvar y
- .l insert end 5 6 7 8
+ listbox .l2
+ .l2 configure -listvar x
+ .l2 configure -listvar y
+ .l2 insert end 5 6 7 8
list $x $y
-} [list [list a b c d] [list 1 2 3 4 5 6 7 8]]
-test listbox-4.13 {ConfigureListbox, no listvar -> non-existant listvar} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l2
+} -result [list [list a b c d] [list 1 2 3 4 5 6 7 8]]
+test listbox-4.13 {ConfigureListbox, no listvar -> non-existant listvar} -setup {
+ destroy .l2
+} -body {
catch {unset x}
- listbox .l
- .l insert end a b c d
- .l configure -listvar x
+ listbox .l2
+ .l2 insert end a b c d
+ .l2 configure -listvar x
set x
-} [list a b c d]
-test listbox-4.14 {ConfigureListbox, non-existant listvar} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l2
+} -result [list a b c d]
+test listbox-4.14 {ConfigureListbox, non-existant listvar} -setup {
+ destroy .l2
+} -body {
catch {unset x}
- listbox .l -listvar x
+ listbox .l2 -listvar x
list [info exists x] $x
-} [list 1 {}]
-test listbox-4.15 {ConfigureListbox, listvar -> non-existant listvar} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l2
+} -result [list 1 {}]
+test listbox-4.15 {ConfigureListbox, listvar -> non-existant listvar} -setup {
+ destroy .l2
+} -body {
catch {unset y}
set x [list a b c d]
- listbox .l -listvar x
- .l configure -listvar y
+ listbox .l2 -listvar x
+ .l2 configure -listvar y
list [info exists y] $y
-} [list 1 [list a b c d]]
-test listbox-4.16 {ConfigureListbox, listvar -> same listvar} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l2
+} -result [list 1 [list a b c d]]
+test listbox-4.16 {ConfigureListbox, listvar -> same listvar} -setup {
+ destroy .l2
+} -body {
set x [list a b c d]
- listbox .l -listvar x
- .l configure -listvar x
+ listbox .l2 -listvar x
+ .l2 configure -listvar x
set x
-} [list a b c d]
-test listbox-4.17 {ConfigureListbox, no listvar -> no listvar} {
- catch {destroy .l}
- listbox .l
- .l insert end a b c d
- .l configure -listvar {}
- .l get 0 end
-} [list a b c d]
-test listbox-4.18 {ConfigureListbox, no listvar -> bad listvar} {
- catch {destroy .l}
- listbox .l
- .l insert end a b c d
+} -cleanup {
+ destroy .l2
+} -result [list a b c d]
+test listbox-4.17 {ConfigureListbox, no listvar -> no listvar} -setup {
+ destroy .l2
+} -body {
+ listbox .l2
+ .l2 insert end a b c d
+ .l2 configure -listvar {}
+ .l2 get 0 end
+} -cleanup {
+ destroy .l2
+} -result [list a b c d]
+test listbox-4.18 {ConfigureListbox, no listvar -> bad listvar} -setup {
+ destroy .l2
+} -body {
+ listbox .l2
+ .l2 insert end a b c d
set x "this is a \" bad list"
- catch {.l configure -listvar x} result
- list [.l get 0 end] [.l cget -listvar] $result
-} [list [list a b c d] {} \
+ catch {.l2 configure -listvar x} result
+ list [.l2 get 0 end] [.l2 cget -listvar] $result
+} -cleanup {
+ destroy .l2
+} -result [list [list a b c d] {} \
"unmatched open quote in list: invalid -listvariable value"]
-test listbox-4.19 {ConfigureListbox, no listvar -> bad non-existent listvar} {
- catch {destroy .l}
+test listbox-4.19 {ConfigureListbox, no listvar -> bad non-existent listvar} -setup {
+ destroy .l2
+} -body {
unset -nocomplain ::foo
- listbox .l -listvar foo
- .l insert end a b c d
- catch {.l configure -listvar ::zoo::bar::foo} result
- list [.l get 0 end] [.l cget -listvar] $foo $result
-} [list [list a b c d] foo [list a b c d] \
+ listbox .l2 -listvar foo
+ .l2 insert end a b c d
+ catch {.l2 configure -listvar ::zoo::bar::foo} result
+ list [.l2 get 0 end] [.l2 cget -listvar] $foo $result
+} -cleanup {
+ destroy .l2
+} -result [list [list a b c d] foo [list a b c d] \
{can't set "::zoo::bar::foo": parent namespace doesn't exist}]
+
# No tests for DisplayListbox: I don't know how to test this procedure.
-test listbox-5.1 {ListboxComputeGeometry procedure} {fonts} {
- catch {destroy .l}
+test listbox-5.1 {ListboxComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ destroy .l
+} -body {
listbox .l -font $fixed -width 15 -height 20
pack .l
list [winfo reqwidth .l] [winfo reqheight .l]
-} {115 328}
-test listbox-5.2 {ListboxComputeGeometry procedure} {fonts} {
- catch {destroy .l}
+} -result {115 328}
+test listbox-5.2 {ListboxComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ destroy .l
+} -body {
listbox .l -font $fixed -width 0 -height 10
pack .l
update
list [winfo reqwidth .l] [winfo reqheight .l]
-} {17 168}
-test listbox-5.3 {ListboxComputeGeometry procedure} {fonts} {
- catch {destroy .l}
+} -result {17 168}
+test listbox-5.3 {ListboxComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ destroy .l
+} -body {
listbox .l -font $fixed -width 0 -height 10 -bd 3
.l insert 0 Short "Really much longer" Longer
pack .l
update
list [winfo reqwidth .l] [winfo reqheight .l]
-} {138 170}
-test listbox-5.4 {ListboxComputeGeometry procedure} {fonts} {
- catch {destroy .l}
+} -result {138 170}
+test listbox-5.4 {ListboxComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ destroy .l
+} -body {
listbox .l -font $fixed -width 10 -height 0
pack .l
update
list [winfo reqwidth .l] [winfo reqheight .l]
-} {80 24}
-test listbox-5.5 {ListboxComputeGeometry procedure} {fonts} {
- catch {destroy .l}
+} -result {80 24}
+test listbox-5.5 {ListboxComputeGeometry procedure} -constraints {
+ fonts
+} -setup {
+ destroy .l
+} -body {
listbox .l -font $fixed -width 10 -height 0 -highlightthickness 0
.l insert 0 Short "Really much longer" Longer
pack .l
update
list [winfo reqwidth .l] [winfo reqheight .l]
-} {76 52}
-test listbox-5.6 {ListboxComputeGeometry procedure} {
+} -result {76 52}
+test listbox-5.6 {ListboxComputeGeometry procedure} -setup {
+ destroy .l
+} -body {
# If "0" in selected font had 0 width, caused divide-by-zero error.
- catch {destroy .l}
pack [listbox .l -font {{open look glyph}}]
update
-} {}
+} -cleanup {
+ destroy .l
+} -result {}
-catch {destroy .l}
+# Listbox used in 6.*, 7.* tests
+destroy .l
listbox .l -height 2 -xscrollcommand "record x" -yscrollcommand "record y"
pack .l
update
-test listbox-6.1 {InsertEls procedure} {
+test listbox-6.1 {InsertEls procedure} -body {
.l delete 0 end
.l insert end a b c d
.l insert 5 x y z
.l insert 2 A
.l insert 0 q r s
.l get 0 end
-} {q r s a b A c d x y z}
-test listbox-6.2 {InsertEls procedure} {
+} -result {q r s a b A c d x y z}
+test listbox-6.2 {InsertEls procedure} -body {
.l delete 0 end
.l insert 0 a b c d e f g h i j
.l selection anchor 2
.l insert 2 A B
.l index anchor
-} {4}
-test listbox-6.3 {InsertEls procedure} {
+} -result {4}
+test listbox-6.3 {InsertEls procedure} -body {
.l delete 0 end
.l insert 0 a b c d e f g h i j
.l selection anchor 2
.l insert 3 A B
.l index anchor
-} {2}
-test listbox-6.4 {InsertEls procedure} {
+} -result {2}
+test listbox-6.4 {InsertEls procedure} -body {
.l delete 0 end
.l insert 0 a b c d e f g h i j
.l yview 3
update
.l insert 2 A B
.l index @0,0
-} {5}
-test listbox-6.5 {InsertEls procedure} {
+} -result {5}
+test listbox-6.5 {InsertEls procedure} -body {
.l delete 0 end
.l insert 0 a b c d e f g h i j
.l yview 3
update
.l insert 3 A B
.l index @0,0
-} {3}
-test listbox-6.6 {InsertEls procedure} {
+} -result {3}
+test listbox-6.6 {InsertEls procedure} -body {
.l delete 0 end
.l insert 0 a b c d e f g h i j
.l activate 5
.l insert 5 A B
.l index active
-} {7}
-test listbox-6.7 {InsertEls procedure} {
+} -result {7}
+test listbox-6.7 {InsertEls procedure} -body {
.l delete 0 end
.l insert 0 a b c d e f g h i j
.l activate 5
.l insert 6 A B
.l index active
-} {5}
-test listbox-6.8 {InsertEls procedure} {
+} -result {5}
+test listbox-6.8 {InsertEls procedure} -body {
.l delete 0 end
.l insert 0 a b c
.l index active
-} {2}
-test listbox-6.9 {InsertEls procedure} {
+} -result {2}
+test listbox-6.9 {InsertEls procedure} -body {
.l delete 0 end
.l insert 0
.l index active
-} {0}
-test listbox-6.10 {InsertEls procedure} {
+} -result {0}
+test listbox-6.10 {InsertEls procedure} -body {
.l delete 0 end
.l insert 0 a b "two words" c d e f g h i j
update
@@ -1070,8 +1560,8 @@ test listbox-6.10 {InsertEls procedure} {
.l insert 0 word
update
set log
-} {{y 0 0.166667}}
-test listbox-6.11 {InsertEls procedure} {
+} -result {{y 0 0.166667}}
+test listbox-6.11 {InsertEls procedure} -body {
.l delete 0 end
.l insert 0 a b "two words" c d e f g h i j
update
@@ -1079,9 +1569,12 @@ test listbox-6.11 {InsertEls procedure} {
.l insert 0 "much longer entry"
update
set log
-} {{y 0 0.166667} {x 0 1}}
-test listbox-6.12 {InsertEls procedure} {fonts} {
- catch {destroy .l2}
+} -result {{y 0 0.166667} {x 0 1}}
+test listbox-6.12 {InsertEls procedure} -constraints {
+ fonts
+} -setup {
+ destroy .l2
+} -body {
listbox .l2 -width 0 -height 0
pack .l2 -side top
.l2 insert 0 a b "two words" c d
@@ -1089,23 +1582,31 @@ test listbox-6.12 {InsertEls procedure} {fonts} {
lappend x [winfo reqwidth .l2] [winfo reqheight .l2]
.l2 insert 0 "much longer entry"
lappend x [winfo reqwidth .l2] [winfo reqheight .l2]
-} {80 93 122 110}
-test listbox-6.13 {InsertEls procedure, check -listvar update} {
- catch {destroy .l2}
+} -cleanup {
+ destroy .l2
+} -result {80 93 122 110}
+test listbox-6.13 {InsertEls procedure, check -listvar update} -setup {
+ destroy .l2
+} -body {
set x [list a b c d]
listbox .l2 -listvar x
.l2 insert 0 1 2 3 4
set x
-} [list 1 2 3 4 a b c d]
-test listbox-6.14 {InsertEls procedure, check selection update} {
- catch {destroy .l2}
+} -cleanup {
+ destroy .l2
+} -result [list 1 2 3 4 a b c d]
+test listbox-6.14 {InsertEls procedure, check selection update} -setup {
+ destroy .l2
+} -body {
listbox .l2
.l2 insert 0 0 1 2 3 4
.l2 selection set 2 4
.l2 insert 0 a
.l2 curselection
-} [list 3 4 5]
-test listbox-6.15 {InsertEls procedure, lost namespaced listvar} {
+} -cleanup {
+ destroy .l2
+} -result [list 3 4 5]
+test listbox-6.15 {InsertEls procedure, lost namespaced listvar} -body {
destroy .l2
namespace eval test { variable foo {a b} }
listbox .l2 -listvar ::test::foo
@@ -1115,137 +1616,139 @@ test listbox-6.15 {InsertEls procedure, lost namespaced listvar} {
.l2 insert end e f
catch {set ::test::foo} result
list [.l2 get 0 end] [.l2 cget -listvar] $result
-} [list [list a b c e f] ::test::foo \
+} -cleanup {
+ destroy .l2
+} -result [list [list a b c e f] ::test::foo \
{can't read "::test::foo": no such variable}]
-test listbox-7.1 {DeleteEls procedure} {
+test listbox-7.1 {DeleteEls procedure} -body {
.l delete 0 end
.l insert 0 a b c d e f g h i j
.l selection set 1 6
.l delete 4 3
list [.l size] [selection get]
-} {10 {b
+} -result {10 {b
c
d
e
f
g}}
-test listbox-7.2 {DeleteEls procedure} {
+test listbox-7.2 {DeleteEls procedure} -body {
.l delete 0 end
.l insert 0 a b c d e f g h i j
.l selection set 3 6
.l delete 4 4
list [.l size] [.l get 4] [.l curselection]
-} {9 f {3 4 5}}
-test listbox-7.3 {DeleteEls procedure} {
+} -result {9 f {3 4 5}}
+test listbox-7.3 {DeleteEls procedure} -body {
.l delete 0 end
.l insert 0 a b c d e f g h i j
.l delete 0 3
list [.l size] [.l get 0] [.l get 1]
-} {6 e f}
-test listbox-7.4 {DeleteEls procedure} {
+} -result {6 e f}
+test listbox-7.4 {DeleteEls procedure} -body {
.l delete 0 end
.l insert 0 a b c d e f g h i j
.l delete 8 1000
list [.l size] [.l get 7]
-} {8 h}
-test listbox-7.5 {DeleteEls procedure} {
+} -result {8 h}
+test listbox-7.5 {DeleteEls procedure} -body {
.l delete 0 end
.l insert 0 a b c d e f g h i j
.l selection anchor 2
.l delete 0 1
.l index anchor
-} {0}
-test listbox-7.6 {DeleteEls procedure} {
+} -result {0}
+test listbox-7.6 {DeleteEls procedure} -body {
.l delete 0 end
.l insert 0 a b c d e f g h i j
.l selection anchor 2
.l delete 2
.l index anchor
-} {2}
-test listbox-7.7 {DeleteEls procedure} {
+} -result {2}
+test listbox-7.7 {DeleteEls procedure} -body {
.l delete 0 end
.l insert 0 a b c d e f g h i j
.l selection anchor 4
.l delete 2 5
.l index anchor
-} {2}
-test listbox-7.8 {DeleteEls procedure} {
+} -result {2}
+test listbox-7.8 {DeleteEls procedure} -body {
.l delete 0 end
.l insert 0 a b c d e f g h i j
.l selection anchor 3
.l delete 4 5
.l index anchor
-} {3}
-test listbox-7.9 {DeleteEls procedure} {
+} -result {3}
+test listbox-7.9 {DeleteEls procedure} -body {
.l delete 0 end
.l insert 0 a b c d e f g h i j
.l yview 3
update
.l delete 1 2
.l index @0,0
-} {1}
-test listbox-7.10 {DeleteEls procedure} {
+} -result {1}
+test listbox-7.10 {DeleteEls procedure} -body {
.l delete 0 end
.l insert 0 a b c d e f g h i j
.l yview 3
update
.l delete 3 4
.l index @0,0
-} {3}
-test listbox-7.11 {DeleteEls procedure} {
+} -result {3}
+test listbox-7.11 {DeleteEls procedure} -body {
.l delete 0 end
.l insert 0 a b c d e f g h i j
.l yview 3
update
.l delete 4 6
.l index @0,0
-} {3}
-test listbox-7.12 {DeleteEls procedure} {
+} -result {3}
+test listbox-7.12 {DeleteEls procedure} -body {
.l delete 0 end
.l insert 0 a b c d e f g h i j
.l yview 3
update
.l delete 3 end
.l index @0,0
-} {1}
-test listbox-7.13 {DeleteEls procedure, updating view with partial last line} {
+} -result {1}
+test listbox-7.13 {DeleteEls procedure, updating view with partial last line} -body {
mkPartial
.partial.l yview 8
update
.partial.l delete 10 13
.partial.l index @0,0
-} {7}
-test listbox-7.14 {DeleteEls procedure} {
+} -result {7}
+test listbox-7.14 {DeleteEls procedure} -body {
.l delete 0 end
.l insert 0 a b c d e f g h i j
.l activate 6
.l delete 3 4
.l index active
-} {4}
-test listbox-7.15 {DeleteEls procedure} {
+} -result {4}
+test listbox-7.15 {DeleteEls procedure} -body {
.l delete 0 end
.l insert 0 a b c d e f g h i j
.l activate 6
.l delete 5 7
.l index active
-} {5}
-test listbox-7.16 {DeleteEls procedure} {
+} -result {5}
+test listbox-7.16 {DeleteEls procedure} -body {
.l delete 0 end
.l insert 0 a b c d e f g h i j
.l activate 6
.l delete 5 end
.l index active
-} {4}
-test listbox-7.17 {DeleteEls procedure} {
+} -result {4}
+test listbox-7.17 {DeleteEls procedure} -body {
.l delete 0 end
.l insert 0 a b c d e f g h i j
.l activate 6
.l delete 0 end
.l index active
-} {0}
-test listbox-7.18 {DeleteEls procedure} {
+} -result {0}
+test listbox-7.18 {DeleteEls procedure} -body {
.l delete 0 end
.l insert 0 a b c "two words" d e f g h i j
update
@@ -1253,8 +1756,8 @@ test listbox-7.18 {DeleteEls procedure} {
.l delete 4 6
update
set log
-} {{y 0 0.25}}
-test listbox-7.19 {DeleteEls procedure} {
+} -result {{y 0 0.25}}
+test listbox-7.19 {DeleteEls procedure} -body {
.l delete 0 end
.l insert 0 a b c "two words" d e f g h i j
update
@@ -1262,9 +1765,12 @@ test listbox-7.19 {DeleteEls procedure} {
.l delete 3
update
set log
-} {{y 0 0.2} {x 0 1}}
-test listbox-7.20 {DeleteEls procedure} {fonts} {
- catch {destroy .l2}
+} -result {{y 0 0.2} {x 0 1}}
+test listbox-7.20 {DeleteEls procedure} -constraints {
+ fonts
+} -setup {
+ destroy .l2
+} -body {
listbox .l2 -width 0 -height 0
pack .l2 -side top
.l2 insert 0 a b "two words" c d e f g
@@ -1272,28 +1778,37 @@ test listbox-7.20 {DeleteEls procedure} {fonts} {
lappend x [winfo reqwidth .l2] [winfo reqheight .l2]
.l2 delete 2 4
lappend x [winfo reqwidth .l2] [winfo reqheight .l2]
-} {80 144 17 93}
-catch {destroy .l2}
-test listbox-7.21 {DeleteEls procedure, check -listvar update} {
- catch {destroy .l2}
+} -result {80 144 17 93}
+test listbox-7.21 {DeleteEls procedure, check -listvar update} -setup {
+ destroy .l2
+} -body {
set x [list a b c d]
listbox .l2 -listvar x
.l2 delete 0 1
set x
-} [list c d]
+} -result [list c d]
-test listbox-8.1 {ListboxEventProc procedure} {fonts} {
- catch {destroy .l}
+
+test listbox-8.1 {ListboxEventProc procedure} -constraints {
+ fonts
+} -setup {
+ destroy .l
+} -body {
listbox .l -setgrid 1
pack .l
update
set x [getsize .]
destroy .l
list $x [getsize .] [winfo exists .l] [info command .l]
-} {20x10 150x178 0 {}}
+} -cleanup {
+ destroy .l
+} -result {20x10 150x178 0 {}}
resetGridInfo
-test listbox-8.2 {ListboxEventProc procedure} {fonts} {
- catch {destroy .l}
+test listbox-8.2 {ListboxEventProc procedure} -constraints {
+ fonts
+} -setup {
+ destroy .l
+} -body {
listbox .l -height 5 -width 10
.l insert 0 a b c "A string that is very very long" d e f g h i j k
pack .l
@@ -1301,9 +1816,12 @@ test listbox-8.2 {ListboxEventProc procedure} {fonts} {
place .l -width 50 -height 80
update
list [format {%.6g %.6g} {*}[.l xview]] [format {%.6g %.6g} {*}[.l yview]]
-} {{0 0.222222} {0 0.333333}}
-test listbox-8.3 {ListboxEventProc procedure} {
+} -cleanup {
+ destroy .l
+} -result {{0 0.222222} {0 0.333333}}
+test listbox-8.3 {ListboxEventProc procedure} -setup {
deleteWindows
+} -body {
listbox .l1 -bg #543210
rename .l1 .l2
set x {}
@@ -1311,107 +1829,257 @@ test listbox-8.3 {ListboxEventProc procedure} {
lappend x [.l2 cget -bg]
destroy .l1
lappend x [info command .l*] [winfo children .]
-} {.l1 #543210 {} {}}
+} -cleanup {
+ deleteWindows
+} -result {.l1 #543210 {} {}}
+
-test listbox-9.1 {ListboxCmdDeletedProc procedure} {
+test listbox-9.1 {ListboxCmdDeletedProc procedure} -setup {
deleteWindows
+} -body {
listbox .l1
rename .l1 {}
list [info command .l*] [winfo children .]
-} {{} {}}
-test listbox-9.2 {ListboxCmdDeletedProc procedure, disabling -setgrid} fonts {
- catch {destroy .top}
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test listbox-9.2 {ListboxCmdDeletedProc procedure, disabling -setgrid} -constraints {
+ fonts
+} -setup {
+ destroy .top
+} -body {
toplevel .top
wm geom .top +0+0
listbox .top.l -setgrid 1 -width 20 -height 10
pack .top.l
update
- set x [wm geometry .top]
+ set x [getsize .top]
rename .top.l {}
update
- lappend x [wm geometry .top]
+ lappend x [getsize .top]
+} -cleanup {
destroy .top
- set x
-} {20x10+0+0 150x178+0+0}
+} -result {20x10 150x178}
-catch {destroy .l}
-listbox .l
-pack .l
-.l delete 0 end
-.l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
-test listbox-10.1 {GetListboxIndex procedure} {
+
+# Listbox used in 10.* tests
+destroy .l
+test listbox-10.1 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
.l activate 3
+ update
list [.l activate 3; .l index active] [.l activate 6; .l index active]
-} {3 6}
-test listbox-10.2 {GetListboxIndex procedure} {
+} -cleanup {
+ destroy .l
+} -result {3 6}
+test listbox-10.2 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
.l selection anchor 2
+ update
.l index anchor
-} 2
-test listbox-10.3 {GetListboxIndex procedure} {
+} -cleanup {
+ destroy .l
+} -result 2
+test listbox-10.3 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
.l insert end A B C D E
.l selection anchor end
+ update
.l delete 12 end
list [.l index anchor] [.l index end]
-} {12 12}
-test listbox-10.4 {GetListboxIndex procedure} {
- list [catch {.l index a} msg] $msg
-} {1 {bad listbox index "a": must be active, anchor, end, @x,y, or a number}}
-test listbox-10.5 {GetListboxIndex procedure} {
+} -cleanup {
+ destroy .l
+} -result {12 12}
+test listbox-10.4 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
+ .l index a
+} -cleanup {
+ destroy .l
+} -returnCodes error -result {bad listbox index "a": must be active, anchor, end, @x,y, or a number}
+test listbox-10.5 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
.l index end
-} {12}
-test listbox-10.6 {GetListboxIndex procedure} {
+} -cleanup {
+ destroy .l
+} -result {12}
+test listbox-10.6 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
.l get end
-} {el11}
-test listbox-10.7 {GetListboxIndex procedure} {
+} -cleanup {
+ destroy .l
+} -result {el11}
+test listbox-10.7 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
.l delete 0 end
+ update
.l index end
-} 0
-.l delete 0 end
-.l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
-update
-test listbox-10.8 {GetListboxIndex procedure} {
- list [catch {.l index @} msg] $msg
-} {1 {bad listbox index "@": must be active, anchor, end, @x,y, or a number}}
-test listbox-10.9 {GetListboxIndex procedure} {
- list [catch {.l index @foo} msg] $msg
-} {1 {bad listbox index "@foo": must be active, anchor, end, @x,y, or a number}}
-test listbox-10.10 {GetListboxIndex procedure} {
- list [catch {.l index @1x3} msg] $msg
-} {1 {bad listbox index "@1x3": must be active, anchor, end, @x,y, or a number}}
-test listbox-10.11 {GetListboxIndex procedure} {
- list [catch {.l index @1,} msg] $msg
-} {1 {bad listbox index "@1,": must be active, anchor, end, @x,y, or a number}}
-test listbox-10.12 {GetListboxIndex procedure} {
- list [catch {.l index @1,foo} msg] $msg
-} {1 {bad listbox index "@1,foo": must be active, anchor, end, @x,y, or a number}}
-test listbox-10.13 {GetListboxIndex procedure} {
- list [catch {.l index @1,2x} msg] $msg
-} {1 {bad listbox index "@1,2x": must be active, anchor, end, @x,y, or a number}}
-test listbox-10.14 {GetListboxIndex procedure} {fonts} {
+} -cleanup {
+ destroy .l
+} -result 0
+test listbox-10.8 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
+ .l index @
+} -cleanup {
+ destroy .l
+} -returnCodes error -result {bad listbox index "@": must be active, anchor, end, @x,y, or a number}
+test listbox-10.9 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
+ .l index @foo
+} -cleanup {
+ destroy .l
+} -returnCodes error -result {bad listbox index "@foo": must be active, anchor, end, @x,y, or a number}
+test listbox-10.10 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
+ .l index @1x3
+} -cleanup {
+ destroy .l
+} -returnCodes error -result {bad listbox index "@1x3": must be active, anchor, end, @x,y, or a number}
+test listbox-10.11 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
+ .l index @1,
+} -cleanup {
+ destroy .l
+} -returnCodes error -result {bad listbox index "@1,": must be active, anchor, end, @x,y, or a number}
+test listbox-10.12 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
+ .l index @1,foo
+} -cleanup {
+ destroy .l
+} -returnCodes error -result {bad listbox index "@1,foo": must be active, anchor, end, @x,y, or a number}
+test listbox-10.13 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
+ .l index @1,2x
+} -cleanup {
+ destroy .l
+} -returnCodes error -result {bad listbox index "@1,2x": must be active, anchor, end, @x,y, or a number}
+test listbox-10.14 {GetListboxIndex procedure} -constraints {
+ fonts
+} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
list [.l index @5,57] [.l index @5,58]
-} {3 3}
-test listbox-10.15 {GetListboxIndex procedure} {
- list [catch {.l index 1xy} msg] $msg
-} {1 {bad listbox index "1xy": must be active, anchor, end, @x,y, or a number}}
-test listbox-10.16 {GetListboxIndex procedure} {
+} -cleanup {
+ .l delete 0 end
+} -cleanup {
+ destroy .l
+} -result {3 3}
+test listbox-10.15 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
+ .l index 1xy
+} -cleanup {
+ destroy .l
+} -returnCodes error -result {bad listbox index "1xy": must be active, anchor, end, @x,y, or a number}
+test listbox-10.16 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
.l index 3
-} {3}
-test listbox-10.17 {GetListboxIndex procedure} {
+} -cleanup {
+ destroy .l
+} -result {3}
+test listbox-10.17 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
.l index 20
-} {20}
-test listbox-10.18 {GetListboxIndex procedure} {
+} -cleanup {
+ destroy .l
+} -result {20}
+test listbox-10.18 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
.l get 20
-} {}
-test listbox-10.19 {GetListboxIndex procedure} {
+} -cleanup {
+ destroy .l
+} -result {}
+test listbox-10.19 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
+ update
.l index -2
-} -2
-test listbox-10.20 {GetListboxIndex procedure} {
+} -cleanup {
+ destroy .l
+} -result -2
+test listbox-10.20 {GetListboxIndex procedure} -setup {
+ destroy .l
+} -body {
+ pack [listbox .l]
+ .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
.l delete 0 end
+ update
.l index 1
-} 1
+} -cleanup {
+ destroy .l
+} -result 1
+
-test listbox-11.1 {ChangeListboxView procedure, boundary conditions for index} {
- catch {destroy .l}
+test listbox-11.1 {ChangeListboxView procedure, boundary conditions for index} -setup {
+ destroy .l
+} -body {
listbox .l -height 5
pack .l
.l insert 0 a b c d e f g h i j
@@ -1421,9 +2089,12 @@ test listbox-11.1 {ChangeListboxView procedure, boundary conditions for index} {
.l yview -1
update
lappend x [.l index @0,0]
-} {3 0}
-test listbox-11.2 {ChangeListboxView procedure, boundary conditions for index} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result {3 0}
+test listbox-11.2 {ChangeListboxView procedure, boundary conditions for index} -setup {
+ destroy .l
+} -body {
listbox .l -height 5
pack .l
.l insert 0 a b c d e f g h i j
@@ -1433,9 +2104,12 @@ test listbox-11.2 {ChangeListboxView procedure, boundary conditions for index} {
.l yview 20
update
lappend x [.l index @0,0]
-} {3 5}
-test listbox-11.3 {ChangeListboxView procedure} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result {3 5}
+test listbox-11.3 {ChangeListboxView procedure} -setup {
+ destroy .l
+} -body {
listbox .l -height 5 -yscrollcommand "record y"
pack .l
.l insert 0 a b c d e f g h i j
@@ -1444,9 +2118,12 @@ test listbox-11.3 {ChangeListboxView procedure} {
.l yview 2
update
list [format {%.6g %.6g} {*}[.l yview]] $log
-} {{0.2 0.7} {{y 0.2 0.7}}}
-test listbox-11.4 {ChangeListboxView procedure} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result {{0.2 0.7} {{y 0.2 0.7}}}
+test listbox-11.4 {ChangeListboxView procedure} -setup {
+ destroy .l
+} -body {
listbox .l -height 5 -yscrollcommand "record y"
pack .l
.l insert 0 a b c d e f g h i j
@@ -1455,9 +2132,12 @@ test listbox-11.4 {ChangeListboxView procedure} {
.l yview 8
update
list [format {%.6g %.6g} {*}[.l yview]] $log
-} {{0.5 1} {{y 0.5 1}}}
-test listbox-11.5 {ChangeListboxView procedure} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result {{0.5 1} {{y 0.5 1}}}
+test listbox-11.5 {ChangeListboxView procedure} -setup {
+ destroy .l
+} -body {
listbox .l -height 5 -yscrollcommand "record y"
pack .l
.l insert 0 a b c d e f g h i j
@@ -1467,40 +2147,55 @@ test listbox-11.5 {ChangeListboxView procedure} {
.l yview 3
update
list [format {%.6g %.6g} {*}[.l yview]] $log
-} {{0.3 0.8} {}}
-test listbox-11.6 {ChangeListboxView procedure, partial last line} {
+} -cleanup {
+ destroy .l
+} -result {{0.3 0.8} {}}
+test listbox-11.6 {ChangeListboxView procedure, partial last line} -body {
mkPartial
.partial.l yview 13
.partial.l index @0,0
-} {11}
+} -cleanup {
+ destroy .l
+} -result {11}
-catch {destroy .l}
+
+# Listbox used in 12.* tests
+destroy .l
listbox .l -font $fixed -xscrollcommand "record x" -width 10
.l insert 0 0123456789a123456789b123456789c123456789d123456789e123456789f123456789g123456789h123456789i123456789
pack .l
update
-test listbox-12.1 {ChangeListboxOffset procedure} {fonts} {
+test listbox-12.1 {ChangeListboxOffset procedure} -constraints {
+ fonts
+} -body {
set log {}
.l xview 99
update
list [format {%.6g %.6g} {*}[.l xview]] $log
-} {{0.9 1} {{x 0.9 1}}}
-test listbox-12.2 {ChangeListboxOffset procedure} {fonts} {
+} -result {{0.9 1} {{x 0.9 1}}}
+test listbox-12.2 {ChangeListboxOffset procedure} -constraints {
+ fonts
+} -body {
set log {}
+ .l xview 99
.l xview moveto -.25
update
list [format {%.6g %.6g} {*}[.l xview]] $log
-} {{0 0.1} {{x 0 0.1}}}
-test listbox-12.3 {ChangeListboxOffset procedure} {fonts} {
+} -result {{0 0.1} {{x 0 0.1}}}
+test listbox-12.3 {ChangeListboxOffset procedure} -constraints {
+ fonts
+} -body {
.l xview 10
update
set log {}
.l xview 10
update
list [format {%.6g %.6g} {*}[.l xview]] $log
-} {{0.1 0.2} {}}
+} -result {{0.1 0.2} {}}
+
-catch {destroy .l}
+# Listbox used in 13.* tests
+destroy .l
listbox .l -font $fixed -width 10 -height 5
pack .l
.l insert 0 a bb c d e f g h i j k l m n o p q r s
@@ -1508,15 +2203,19 @@ pack .l
update
set width [expr [lindex [.l bbox 2] 2] - [lindex [.l bbox 1] 2]]
set height [expr [lindex [.l bbox 2] 1] - [lindex [.l bbox 1] 1]]
-test listbox-13.1 {ListboxScanTo procedure} {fonts} {
+test listbox-13.1 {ListboxScanTo procedure} -constraints {
+ fonts
+} -body {
.l yview 0
.l xview 0
.l scan mark 10 20
.l scan dragto [expr 10-$width] [expr 20-$height]
update
list [format {%.6g %.6g} {*}[.l xview]] [format {%.6g %.6g} {*}[.l yview]]
-} {{0.2 0.4} {0.5 0.75}}
-test listbox-13.2 {ListboxScanTo procedure} {fonts} {
+} -result {{0.2 0.4} {0.5 0.75}}
+test listbox-13.2 {ListboxScanTo procedure} -constraints {
+ fonts
+} -body {
.l yview 5
.l xview 10
.l scan mark 10 20
@@ -1526,8 +2225,10 @@ test listbox-13.2 {ListboxScanTo procedure} {fonts} {
.l scan dragto [expr 20-$width] [expr 40-$height]
update
lappend x [format {%.6g %.6g} {*}[.l xview]] [format {%.6g %.6g} {*}[.l yview]]
-} {{0 0.2} {0 0.25} {0.2 0.4} {0.5 0.75}}
-test listbox-13.3 {ListboxScanTo procedure} {fonts} {
+} -result {{0 0.2} {0 0.25} {0.2 0.4} {0.5 0.75}}
+test listbox-13.3 {ListboxScanTo procedure} -constraints {
+ fonts
+} -body {
.l yview moveto 1.0
.l xview moveto 1.0
.l scan mark 10 20
@@ -1537,40 +2238,55 @@ test listbox-13.3 {ListboxScanTo procedure} {fonts} {
.l scan dragto [expr 5+$width] [expr 10+$height]
update
lappend x [format {%.6g %.6g} {*}[.l xview]] [format {%.6g %.6g} {*}[.l yview]]
-} {{0.8 1} {0.75 1} {0.64 0.84} {0.25 0.5}}
+} -result {{0.8 1} {0.75 1} {0.64 0.84} {0.25 0.5}}
-test listbox-14.1 {NearestListboxElement procedure, partial last line} {
+
+test listbox-14.1 {NearestListboxElement procedure, partial last line} -body {
mkPartial
.partial.l nearest [winfo height .partial.l]
-} {4}
-catch {destroy .l}
+} -result {4}
+# Listbox used in 14.* tests
+destroy .l
listbox .l -font $fixed -width 20 -height 10
.l insert 0 a b c d e f g h i j k l m n o p q r s t
.l yview 4
pack .l
update
-test listbox-14.2 {NearestListboxElement procedure} {fonts} {
+test listbox-14.2 {NearestListboxElement procedure} -constraints {
+ fonts
+} -body {
.l index @50,0
-} {4}
-test listbox-14.3 {NearestListboxElement procedure} {fonts} {
+} -result {4}
+test listbox-14.3 {NearestListboxElement procedure} -constraints {
+ fonts
+} -body {
list [.l index @50,35] [.l index @50,36]
-} {5 6}
-test listbox-14.4 {NearestListboxElement procedure} {fonts} {
+} -result {5 6}
+test listbox-14.4 {NearestListboxElement procedure} -constraints {
+ fonts
+} -body {
.l index @50,200
-} {13}
+} -result {13}
+
-test listbox-15.1 {ListboxSelect procedure} {
+# Listbox used in 15.* 16.* and 17.* tests
+destroy .l
+listbox .l -font $fixed -width 20 -height 10
+pack .l
+update
+test listbox-15.1 {ListboxSelect procedure} -body {
.l delete 0 end
.l insert 0 a b c d e f g h i j k l m n o p
.l select set 2 4
.l select set 7 12
.l select clear 4 7
.l curselection
-} {2 3 8 9 10 11 12}
-test listbox-15.2 {ListboxSelect procedure} {
+} -result {2 3 8 9 10 11 12}
+test listbox-15.2 {ListboxSelect procedure} -setup {
+ destroy .e
+} -body {
.l delete 0 end
.l insert 0 a b c d e f g h i j k l m n o p
- catch {destroy .e}
entry .e
.e insert 0 "This is some text"
.e select from 0
@@ -1579,78 +2295,81 @@ test listbox-15.2 {ListboxSelect procedure} {
set x [selection own]
.l selection set 3
list $x [selection own] [selection get]
-} {.e .l d}
-test listbox-15.3 {ListboxSelect procedure} {
+} -cleanup {
+ destroy .e
+} -result {.e .l d}
+test listbox-15.3 {ListboxSelect procedure} -body {
.l delete 0 end
.l selection clear 0 end
.l select set 0 end
.l curselection
-} {}
-test listbox-15.4 {ListboxSelect procedure, boundary conditions for indices} {
+} -result {}
+test listbox-15.4 {ListboxSelect procedure, boundary conditions for indices} -body {
.l delete 0 end
.l insert 0 a b c d e f
.l select clear 0 end
.l select set -2 -1
.l curselection
-} {}
-test listbox-15.5 {ListboxSelect procedure, boundary conditions for indices} {
+} -result {}
+test listbox-15.5 {ListboxSelect procedure, boundary conditions for indices} -body {
.l delete 0 end
.l insert 0 a b c d e f
.l select clear 0 end
.l select set -1 3
.l curselection
-} {0 1 2 3}
-test listbox-15.6 {ListboxSelect procedure, boundary conditions for indices} {
+} -result {0 1 2 3}
+test listbox-15.6 {ListboxSelect procedure, boundary conditions for indices} -body {
.l delete 0 end
.l insert 0 a b c d e f
.l select clear 0 end
.l select set 2 4
.l curselection
-} {2 3 4}
-test listbox-15.7 {ListboxSelect procedure, boundary conditions for indices} {
+} -result {2 3 4}
+test listbox-15.7 {ListboxSelect procedure, boundary conditions for indices} -body {
.l delete 0 end
.l insert 0 a b c d e f
.l select clear 0 end
.l select set 4 end
.l curselection
-} {4 5}
-test listbox-15.8 {ListboxSelect procedure, boundary conditions for indices} {
+} -result {4 5}
+test listbox-15.8 {ListboxSelect procedure, boundary conditions for indices} -body {
.l delete 0 end
.l insert 0 a b c d e f
.l select clear 0 end
.l select set 4 30
.l curselection
-} {4 5}
-test listbox-15.9 {ListboxSelect procedure, boundary conditions for indices} {
+} -result {4 5}
+test listbox-15.9 {ListboxSelect procedure, boundary conditions for indices} -body {
.l delete 0 end
.l insert 0 a b c d e f
.l select clear 0 end
.l select set end 30
.l curselection
-} {5}
-test listbox-15.10 {ListboxSelect procedure, boundary conditions for indices} {
+} -result {5}
+test listbox-15.10 {ListboxSelect procedure, boundary conditions for indices} -body {
.l delete 0 end
.l insert 0 a b c d e f
.l select clear 0 end
.l select set 20 25
.l curselection
-} {}
+} -result {}
+
-test listbox-16.1 {ListboxFetchSelection procedure} {
+test listbox-16.1 {ListboxFetchSelection procedure} -body {
.l delete 0 end
.l insert 0 a b c "two words" e f g h i \\ k l m n o p
.l selection set 2 4
.l selection set 9
.l selection set 11 12
selection get
-} "c\ntwo words\ne\n\\\nl\nm"
-test listbox-16.2 {ListboxFetchSelection procedure} {
+} -result "c\ntwo words\ne\n\\\nl\nm"
+test listbox-16.2 {ListboxFetchSelection procedure} -body {
.l delete 0 end
.l insert 0 a b c "two words" e f g h i \\ k l m n o p
.l selection set 3
selection get
-} "two words"
-test listbox-16.3 {ListboxFetchSelection procedure, retrieve in several parts} {
+} -result "two words"
+test listbox-16.3 {ListboxFetchSelection procedure, retrieve in several parts} -body {
set long "This is quite a long string\n"
append long $long $long $long $long
append long $long $long $long $long
@@ -1660,38 +2379,48 @@ test listbox-16.3 {ListboxFetchSelection procedure, retrieve in several parts} {
.l selection set 0 end
set sel [selection get]
string compare 1$long\n2$long\n3$long\n4$long\n5$long $sel
-} {0}
-catch {unset long sel}
+} -cleanup {
+ catch {unset long sel}
+} -result {0}
+
-test listbox-17.1 {ListboxLostSelection procedure} {
+test listbox-17.1 {ListboxLostSelection procedure} -setup {
+ destroy .e
+} -body {
.l delete 0 end
.l insert 0 a b c d e
.l select set 0 end
- catch {destroy .e}
entry .e
.e insert 0 "This is some text"
.e select from 0
.e select to 5
.l curselection
-} {}
-test listbox-17.2 {ListboxLostSelection procedure} {
+} -cleanup {
+ destroy .e
+} -result {}
+test listbox-17.2 {ListboxLostSelection procedure} -setup {
+ destroy .e
+} -body {
.l delete 0 end
.l insert 0 a b c d e
.l select set 0 end
.l configure -exportselection 0
- catch {destroy .e}
entry .e
.e insert 0 "This is some text"
.e select from 0
.e select to 5
.l curselection
-} {0 1 2 3 4}
+} -cleanup {
+ destroy .e
+} -result {0 1 2 3 4}
-catch {destroy .l}
+
+# Listbox used in 18.* tests
+destroy .l
listbox .l -font $fixed -width 10 -height 5
pack .l
update
-test listbox-18.1 {ListboxUpdateVScrollbar procedure} {
+test listbox-18.1 {ListboxUpdateVScrollbar procedure} -body {
.l configure -yscrollcommand "record y"
set log {}
.l insert 0 a b c
@@ -1701,37 +2430,40 @@ test listbox-18.1 {ListboxUpdateVScrollbar procedure} {
.l delete 0 end
update
set log
-} {{y 0 1} {y 0 0.625} {y 0 1}}
-test listbox-18.2 {ListboxUpdateVScrollbar procedure, partial last line} {
+} -result {{y 0 1} {y 0 0.625} {y 0 1}}
+test listbox-18.2 {ListboxUpdateVScrollbar procedure, partial last line} -body {
mkPartial
.partial.l configure -yscrollcommand "record y"
set log {}
.partial.l yview 3
update
set log
-} {{y 0.2 0.466667}}
-test listbox-18.3 {ListboxUpdateVScrollbar procedure} {
+} -result {{y 0.2 0.466667}}
+test listbox-18.3 {ListboxUpdateVScrollbar procedure} -body {
proc bgerror args {
- global x errorInfo
- set x [list $args $errorInfo]
+ global x errorInfo
+ set x [list $args $errorInfo]
}
.l configure -yscrollcommand gorp
.l insert 0 foo
update
set x
-} {{{invalid command name "gorp"}} {invalid command name "gorp"
+} -cleanup {
+ rename bgerror {}
+} -result {{{invalid command name "gorp"}} {invalid command name "gorp"
while executing
"gorp 0.0 1.0"
(vertical scrolling command executed by listbox)}}
-if {[info exists bgerror]} {
- rename bgerror {}
-}
-catch {destroy .l}
+
+# Listbox used in 19.* tests
+destroy .l
listbox .l -font $fixed -width 10 -height 5
pack .l
update
-test listbox-19.1 {ListboxUpdateVScrollbar procedure} {fonts} {
+test listbox-19.1 {ListboxUpdateVScrollbar procedure} -constraints {
+ fonts
+} -body {
.l configure -xscrollcommand "record x"
set log {}
.l insert 0 abc
@@ -1741,97 +2473,125 @@ test listbox-19.1 {ListboxUpdateVScrollbar procedure} {fonts} {
.l delete 0 end
update
set log
-} {{x 0 1} {x 0 0.322581} {x 0 1}}
-test listbox-19.2 {ListboxUpdateVScrollbar procedure} {
+} -result {{x 0 1} {x 0 0.322581} {x 0 1}}
+test listbox-19.2 {ListboxUpdateVScrollbar procedure} -body {
proc bgerror args {
- global x errorInfo
- set x [list $args $errorInfo]
+ global x errorInfo
+ set x [list $args $errorInfo]
}
.l configure -xscrollcommand bogus
.l insert 0 foo
update
set x
-} {{{invalid command name "bogus"}} {invalid command name "bogus"
+} -result {{{invalid command name "bogus"}} {invalid command name "bogus"
while executing
"bogus 0.0 1.0"
(horizontal scrolling command executed by listbox)}}
-set l [interp hidden]
-deleteWindows
-test listbox-20.1 {listbox vs hidden commands} {
- catch {destroy .l}
+test listbox-20.1 {listbox vs hidden commands} -setup {
+ deleteWindows
+} -body {
+ set l [interp hidden]
listbox .l
interp hide {} .l
destroy .l
- list [winfo children .] [interp hidden]
-} [list {} $l]
+ set res1 [list [winfo children .] [interp hidden]]
+ set res2 [list {} $l]
+ expr {$res1 eq $res2}
+} -result 1
+
# tests for ListboxListVarProc
-test listbox-21.1 {ListboxListVarProc} {
- catch {destroy .l}
+test listbox-21.1 {ListboxListVarProc} -setup {
+ destroy .l
+} -body {
catch {unset x}
listbox .l -listvar x
set x [list a b c d]
.l get 0 end
-} [list a b c d]
-test listbox-21.2 {ListboxListVarProc} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result [list a b c d]
+test listbox-21.2 {ListboxListVarProc} -setup {
+ destroy .l
+} -body {
set x [list a b c d]
listbox .l -listvar x
unset x
set x
-} [list a b c d]
-test listbox-21.3 {ListboxListVarProc} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result [list a b c d]
+test listbox-21.3 {ListboxListVarProc} -setup {
+ destroy .l
+} -body {
set x [list a b c d]
listbox .l -listvar x
.l configure -listvar {}
unset x
info exists x
-} 0
-test listbox-21.4 {ListboxListVarProc} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result 0
+test listbox-21.4 {ListboxListVarProc} -setup {
+ destroy .l
+} -body {
set x [list a b c d]
listbox .l -listvar x
lappend x e f g
.l size
-} 7
-test listbox-21.5 {ListboxListVarProc, test selection after listvar mod} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result 7
+test listbox-21.5 {ListboxListVarProc, test selection after listvar mod} -setup {
+ destroy .l
+} -body {
set x [list a b c d e f g]
listbox .l -listvar x
.l selection set end
set x [list a b c d]
set x [list 0 1 2 3 4 5 6]
.l curselection
-} {}
-test listbox-21.6 {ListboxListVarProc, test selection after listvar mod} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result {}
+test listbox-21.6 {ListboxListVarProc, test selection after listvar mod} -setup {
+ destroy .l
+} -body {
set x [list a b c d]
listbox .l -listvar x
.l selection set 3
lappend x e f g
.l curselection
-} 3
-test listbox-21.7 {ListboxListVarProc, test selection after listvar mod} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result 3
+test listbox-21.7 {ListboxListVarProc, test selection after listvar mod} -setup {
+ destroy .l
+} -body {
set x [list a b c d]
listbox .l -listvar x
.l selection set 0
set x [linsert $x 0 1 2 3 4]
.l curselection
-} 0
-test listbox-21.8 {ListboxListVarProc, test selection after listvar mod} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result 0
+test listbox-21.8 {ListboxListVarProc, test selection after listvar mod} -setup {
+ destroy .l
+} -body {
set x [list a b c d]
listbox .l -listvar x
.l selection set 2
set x [list a b c]
.l curselection
-} 2
-test listbox-21.9 {ListboxListVarProc, test hscrollbar after listvar mod} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result 2
+test listbox-21.9 {ListboxListVarProc, test hscrollbar after listvar mod} -setup {
+ destroy .l
+} -body {
catch {unset x}
set log {}
listbox .l -font $fixed -width 10 -xscrollcommand "record x" -listvar x
@@ -1842,9 +2602,12 @@ test listbox-21.9 {ListboxListVarProc, test hscrollbar after listvar mod} {
lappend x "00000000000000000000"
update
set log
-} [list {x 0 1} {x 0 1} {x 0 0.5}]
-test listbox-21.10 {ListboxListVarProc, test hscrollbar after listvar mod} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result [list {x 0 1} {x 0 1} {x 0 0.5}]
+test listbox-21.10 {ListboxListVarProc, test hscrollbar after listvar mod} -setup {
+ destroy .l
+} -body {
catch {unset x}
set log {}
listbox .l -font $fixed -width 10 -xscrollcommand "record x" -listvar x
@@ -1857,53 +2620,71 @@ test listbox-21.10 {ListboxListVarProc, test hscrollbar after listvar mod} {
set x [list "0000000000"]
update
set log
-} [list {x 0 1} {x 0 1} {x 0 0.5} {x 0 1}]
-test listbox-21.11 {ListboxListVarProc, bad list} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result [list {x 0 1} {x 0 1} {x 0 0.5} {x 0 1}]
+test listbox-21.11 {ListboxListVarProc, bad list} -setup {
+ destroy .l
+} -body {
catch {unset x}
listbox .l -listvar x
set x [list a b c d]
catch {set x "this is a \" bad list"} result
set result
-} {can't set "x": invalid listvar value}
-test listbox-21.12 {ListboxListVarProc, cleanup item attributes} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result {can't set "x": invalid listvar value}
+test listbox-21.12 {ListboxListVarProc, cleanup item attributes} -setup {
+ destroy .l
+} -body {
set x [list a b c d e f g]
listbox .l -listvar x
.l itemconfigure end -fg red
set x [list a b c d]
set x [list 0 1 2 3 4 5 6]
.l itemcget end -fg
-} {}
-test listbox-21.12a {ListboxListVarProc, cleanup item attributes} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result {}
+test listbox-21.12a {ListboxListVarProc, cleanup item attributes} -setup {
+ destroy .l
+} -body {
set x [list a b c d e f g]
listbox .l -listvar x
.l itemconfigure end -fg red
set x [list a b c d]
set x [list 0 1 2 3 4 5 6]
.l itemcget end -fg
-} {}
-test listbox-21.13 {listbox item configurations and listvar based deletions} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result {}
+test listbox-21.13 {listbox item configurations and listvar based deletions} -setup {
+ destroy .l
+} -body {
catch {unset x}
listbox .l -listvar x
.l insert end a b c
.l itemconfigure 1 -fg red
set x [list b c]
.l itemcget 1 -fg
-} red
-test listbox-21.14 {listbox item configurations and listvar based inserts} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result red
+test listbox-21.14 {listbox item configurations and listvar based inserts} -setup {
+ destroy .l
+} -body {
catch {unset x}
listbox .l -listvar x
.l insert end a b c
.l itemconfigure 0 -fg red
set x [list 1 2 3 4 a b c]
.l itemcget 0 -fg
-} red
-test listbox-21.15 {ListboxListVarProc, update vertical scrollbar} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result red
+test listbox-21.15 {ListboxListVarProc, update vertical scrollbar} -setup {
+ destroy .l
+} -body {
catch {unset x}
set log {}
listbox .l -listvar x -yscrollcommand "record y" -font fixed -height 3
@@ -1912,9 +2693,12 @@ test listbox-21.15 {ListboxListVarProc, update vertical scrollbar} {
lappend x a b c d e f
update
set log
-} [list {y 0 1} {y 0 0.5}]
-test listbox-21.16 {ListboxListVarProc, update vertical scrollbar} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result [list {y 0 1} {y 0 0.5}]
+test listbox-21.16 {ListboxListVarProc, update vertical scrollbar} -setup {
+ destroy .l
+} -body {
catch {unset x}
listbox .l -listvar x -height 3
pack .l
@@ -1930,11 +2714,15 @@ test listbox-21.16 {ListboxListVarProc, update vertical scrollbar} {
update
lappend result [format {%.6g %.6g} {*}[.l yview]]
set result
-} [list {0.5 1} {0 1}]
+} -cleanup {
+ destroy .l
+} -result [list {0.5 1} {0 1}]
+
# UpdateHScrollbar
-test listbox-22.1 {UpdateHScrollbar} {
- catch {destroy .l}
+test listbox-22.1 {UpdateHScrollbar} -setup {
+ destroy .l
+} -body {
set log {}
listbox .l -font $fixed -width 10 -xscrollcommand "record x"
pack .l
@@ -1944,41 +2732,57 @@ test listbox-22.1 {UpdateHScrollbar} {
.l insert end "00000000000000000000"
update
set log
-} [list {x 0 1} {x 0 1} {x 0 0.5}]
+} -cleanup {
+ destroy .l
+} -result [list {x 0 1} {x 0 1} {x 0 0.5}]
+
# ConfigureListboxItem
-test listbox-23.1 {ConfigureListboxItem} {
- catch {destroy .l}
+test listbox-23.1 {ConfigureListboxItem} -setup {
+ destroy .l
+} -body {
listbox .l
catch {.l itemconfigure 0} result
set result
-} {item number "0" out of range}
-test listbox-23.2 {ConfigureListboxItem} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result {item number "0" out of range}
+test listbox-23.2 {ConfigureListboxItem} -setup {
+ destroy .l
+} -body {
listbox .l
.l insert end a b c d
.l itemconfigure 0
-} [list {-background background Background {} {}} \
+} -cleanup {
+ destroy .l
+} -result [list {-background background Background {} {}} \
{-bg -background} \
{-fg -foreground} \
{-foreground foreground Foreground {} {}} \
{-selectbackground selectBackground Foreground {} {}} \
{-selectforeground selectForeground Background {} {}}]
-test listbox-23.3 {ConfigureListboxItem, itemco shortcut} {
- catch {destroy .l}
+test listbox-23.3 {ConfigureListboxItem, itemco shortcut} -setup {
+ destroy .l
+} -body {
listbox .l
.l insert end a b c d
.l itemco 0 -background
-} {-background background Background {} {}}
-test listbox-23.4 {ConfigureListboxItem, wrong num args} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result {-background background Background {} {}}
+test listbox-23.4 {ConfigureListboxItem, wrong num args} -setup {
+ destroy .l
+} -body {
listbox .l
.l insert end a
catch {.l itemco} result
set result
-} {wrong # args: should be ".l itemconfigure index ?option? ?value? ?option value ...?"}
-test listbox-23.5 {ConfigureListboxItem, multiple calls} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result {wrong # args: should be ".l itemconfigure index ?-option? ?value? ?-option value ...?"}
+test listbox-23.5 {ConfigureListboxItem, multiple calls} -setup {
+ destroy .l
+} -body {
listbox .l
set i 0
foreach color {red orange yellow green blue white violet} {
@@ -1991,102 +2795,164 @@ test listbox-23.5 {ConfigureListboxItem, multiple calls} {
list [.l itemcget 0 -bg] [.l itemcget 1 -bg] [.l itemcget 2 -bg] \
[.l itemcget 3 -bg] [.l itemcget 4 -bg] [.l itemcget 5 -bg] \
[.l itemcget 6 -bg]
-} {red orange yellow green blue white violet}
-catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result {red orange yellow green blue white violet}
+
+# Listbox used in 23.6 -23.17 tests
+destroy .l
listbox .l
.l insert end a b c d
-set i 6
-foreach test {
- {-background #ff0000 #ff0000 non-existent
- {unknown color name "non-existent"}}
- {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}}
- {-fg #110022 #110022 bogus {unknown color name "bogus"}}
- {-foreground #110022 #110022 bogus {unknown color name "bogus"}}
- {-selectbackground #110022 #110022 bogus {unknown color name "bogus"}}
- {-selectforeground #654321 #654321 bogus {unknown color name "bogus"}}
-} {
- set name [lindex $test 0]
- test listbox-23.$i {configuration options} {
- .l itemconfigure 0 $name [lindex $test 1]
- list [lindex [.l itemconfigure 0 $name] 4] [.l itemcget 0 $name]
- } [list [lindex $test 2] [lindex $test 2]]
- incr i
- if {[lindex $test 3] != ""} {
- test listbox-23.$i {configuration options} {
- list [catch {.l configure $name [lindex $test 3]} msg] $msg
- } [list 1 [lindex $test 4]]
- }
- .l configure $name [lindex [.l configure $name] 3]
- incr i
-}
+test listbox-23.6 {configuration options} -body {
+ .l itemconfigure 0 -background #ff0000
+ list [lindex [.l itemconfigure 0 -background] 4] [.l itemcget 0 -background]
+} -cleanup {
+ .l configure -background #ffffff
+} -result {{#ff0000} #ff0000}
+test listbox-23.7 {configuration options} -body {
+ .l configure -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test listbox-23.8 {configuration options} -body {
+ .l itemconfigure 0 -bg #ff0000
+ list [lindex [.l itemconfigure 0 -bg] 4] [.l itemcget 0 -bg]
+} -cleanup {
+ .l configure -bg #ffffff
+} -result {{#ff0000} #ff0000}
+test listbox-23.9 {configuration options} -body {
+ .l configure -bg non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test listbox-23.10 {configuration options} -body {
+ .l itemconfigure 0 -fg #110022
+ list [lindex [.l itemconfigure 0 -fg] 4] [.l itemcget 0 -fg]
+} -cleanup {
+ .l configure -fg #000000
+} -result {{#110022} #110022}
+test listbox-23.11 {configuration options} -body {
+ .l configure -fg bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test listbox-23.12 {configuration options} -body {
+ .l itemconfigure 0 -foreground #110022
+ list [lindex [.l itemconfigure 0 -foreground] 4] [.l itemcget 0 -foreground]
+} -cleanup {
+ .l configure -foreground #000000
+} -result {{#110022} #110022}
+test listbox-23.13 {configuration options} -body {
+ .l configure -foreground bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test listbox-23.14 {configuration options} -body {
+ .l itemconfigure 0 -selectbackground #110022
+ list [lindex [.l itemconfigure 0 -selectbackground] 4] [.l itemcget 0 -selectbackground]
+} -cleanup {
+ .l configure -selectbackground #c3c3c3
+} -result {{#110022} #110022}
+test listbox-23.15 {configuration options} -body {
+ .l configure -selectbackground bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test listbox-23.16 {configuration options} -body {
+ .l itemconfigure 0 -selectforeground #654321
+ list [lindex [.l itemconfigure 0 -selectforeground] 4] [.l itemcget 0 -selectforeground]
+} -cleanup {
+ .l configure -selectforeground #000000
+} -result {{#654321} #654321}
+test listbox-23.17 {configuration options} -body {
+ .l configure -selectforeground bogus
+} -returnCodes error -result {unknown color name "bogus"}
+
# ListboxWidgetObjCmd, itemcget
-test listbox-24.1 {itemcget} {
- catch {destroy .l}
+test listbox-24.1 {itemcget} -setup {
+ destroy .l
+} -body {
listbox .l
.l insert end a b c d
.l itemcget 0 -fg
-} {}
-test listbox-24.2 {itemcget} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result {}
+test listbox-24.2 {itemcget} -setup {
+ destroy .l
+} -body {
listbox .l
.l insert end a b c d
.l itemconfigure 0 -fg red
.l itemcget 0 -fg
-} red
-test listbox-24.3 {itemcget} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result red
+test listbox-24.3 {itemcget} -setup {
+ destroy .l
+} -body {
listbox .l
.l insert end a b c d
catch {.l itemcget 0} result
set result
-} {wrong # args: should be ".l itemcget index option"}
-test listbox-24.4 {itemcget, itemcg shortcut} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result {wrong # args: should be ".l itemcget index option"}
+test listbox-24.4 {itemcget, itemcg shortcut} -setup {
+ destroy .l
+} -body {
listbox .l
.l insert end a b c d
catch {.l itemcg 0} result
set result
-} {wrong # args: should be ".l itemcget index option"}
+} -cleanup {
+ destroy .l
+} -result {wrong # args: should be ".l itemcget index option"}
+
# General item configuration issues
-test listbox-25.1 {listbox item configurations and widget based deletions} {
- catch {destroy .l}
+test listbox-25.1 {listbox item configurations and widget based deletions} -setup {
+ destroy .l
+} -body {
listbox .l
.l insert end a
.l itemconfigure 0 -fg red
.l delete 0 end
.l insert end a
.l itemcget 0 -fg
-} {}
-test listbox-25.2 {listbox item configurations and widget based inserts} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result {}
+test listbox-25.2 {listbox item configurations and widget based inserts} -setup {
+ destroy .l
+} -body {
listbox .l
.l insert end a b c
.l itemconfigure 0 -fg red
.l insert 0 1 2 3 4
list [.l itemcget 0 -fg] [.l itemcget 4 -fg]
-} [list {} red]
+} -cleanup {
+ destroy .l
+} -result {{} red}
+
# state issues
-test listbox-26.1 {listbox disabled state disallows inserts} {
- catch {destroy .l}
+test listbox-26.1 {listbox disabled state disallows inserts} -setup {
+ destroy .l
+} -body {
listbox .l
.l insert end a b c
.l configure -state disabled
.l insert end d e f
.l get 0 end
-} [list a b c]
-test listbox-26.2 {listbox disabled state disallows deletions} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result [list a b c]
+test listbox-26.2 {listbox disabled state disallows deletions} -setup {
+ destroy .l
+} -body {
listbox .l
.l insert end a b c
.l configure -state disabled
.l delete 0 end
.l get 0 end
-} [list a b c]
-test listbox-26.3 {listbox disabled state disallows selection modification} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result [list a b c]
+test listbox-26.3 {listbox disabled state disallows selection modification} -setup {
+ destroy .l
+} -body {
listbox .l
.l insert end a b c
.l selection set 0
@@ -2095,58 +2961,89 @@ test listbox-26.3 {listbox disabled state disallows selection modification} {
.l selection clear 0 end
.l selection set 1
.l curselection
-} [list 0 2]
-test listbox-26.4 {listbox disabled state disallows anchor modification} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result [list 0 2]
+test listbox-26.4 {listbox disabled state disallows anchor modification} -setup {
+ destroy .l
+} -body {
listbox .l
.l insert end a b c
.l selection anchor 0
.l configure -state disabled
.l selection anchor 2
.l index anchor
-} 0
-test listbox-26.5 {listbox disabled state disallows active modification} {
- catch {destroy .l}
+} -cleanup {
+ destroy .l
+} -result 0
+test listbox-26.5 {listbox disabled state disallows active modification} -setup {
+ destroy .l
+} -body {
listbox .l
.l insert end a b c
.l activate 0
.l configure -state disabled
.l activate 2
.l index active
-} 0
+} -cleanup {
+ destroy .l
+} -result 0
-test listbox-27.1 {widget deletion while active} {
+
+test listbox-27.1 {widget deletion while active} -setup {
destroy .l
+} -body {
pack [listbox .l]
update
.l configure -cursor xterm -xscrollcommand { destroy .l }
update idle
winfo exists .l
-} 0
+} -cleanup {
+ destroy .l
+} -result 0
-test listbox-28.1 {listbox -activestyle} {
+
+test listbox-28.1 {listbox -activestyle} -setup {
destroy .l
+} -body {
listbox .l -activ non
.l cget -activestyle
-} none
-test listbox-28.2-nonwin {listbox -activestyle} {nonwin} {
+} -cleanup {
+ destroy .l
+} -result none
+test listbox-28.2 {listbox -activestyle} -constraints {
+ nonwin
+} -setup {
destroy .l
+} -body {
listbox .l
.l cget -activestyle
-} dotbox
-test listbox-28.2-win {listbox -activestyle} {win} {
+} -cleanup {
destroy .l
+} -result dotbox
+test listbox-28.3 {listbox -activestyle} -constraints {
+ win
+} -setup {
+ destroy .l
+} -body {
listbox .l
.l cget -activestyle
-} underline
-test listbox-28.3 {listbox -activestyle} {
+} -cleanup {
+ destroy .l
+} -result underline
+test listbox-28.4 {listbox -activestyle} -setup {
destroy .l
+} -body {
listbox .l -activestyle und
.l cget -activestyle
-} underline
+} -cleanup {
+ destroy .l
+} -result underline
-test listbox-29.1 {listbox selection behavior, -state disabled} {
+
+test listbox-29.1 {listbox selection behavior, -state disabled} -setup {
destroy .l
+} -body {
listbox .l
.l insert end 1 2 3
.l selection set 2
@@ -2156,7 +3053,9 @@ test listbox-29.1 {listbox selection behavior, -state disabled} {
# but selection cannot be changed (new behavior since 8.4)
.l selection set 3
lappend out [.l selection includes 2] [.l curselection]
-} {1 1 2}
+} -cleanup {
+ destroy .l
+} -result {1 1 2}
resetGridInfo
deleteWindows
@@ -2165,3 +3064,8 @@ option clear
# cleanup
cleanupTests
return
+
+
+
+
+
diff --git a/tests/main.test b/tests/main.test
index 1d33fbb..7ab624f 100644
--- a/tests/main.test
+++ b/tests/main.test
@@ -8,59 +8,55 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
test main-1.1 {StdinProc} -constraints stdio -setup {
- set script [makeFile {
- close stdin; exit
- } script]
+ set script [makeFile {close stdin; exit} script]
} -body {
- list [catch {exec [interpreter] <$script} msg] $msg
+ exec [interpreter] <$script
} -cleanup {
removeFile script
-} -result {0 {}}
+} -returnCodes ok
-test main-2.1 {Tk_MainEx: -encoding option} -constraints {
- stdio
- } -setup {
- set script [makeFile {} script]
- file delete $script
- set f [open $script w]
- fconfigure $f -encoding utf-8
- puts $f {puts [list $argv0 $argv $tcl_interactive]}
- puts -nonewline $f {puts [string equal \u20ac }
- puts $f "\u20ac]; exit"
- close $f
- catch {set f [open "|[list [interpreter] -encoding utf-8 script]" r]}
- } -body {
- read $f
- } -cleanup {
- close $f
- removeFile script
- } -result [list script {} 0]\n1\n
+test main-2.1 {Tk_MainEx: -encoding option} -constraints stdio -setup {
+ set script [makeFile {} script]
+ file delete $script
+ set f [open $script w]
+ fconfigure $f -encoding utf-8
+ puts $f {puts [list $argv0 $argv $tcl_interactive]}
+ puts -nonewline $f {puts [string equal \u20ac }
+ puts $f "\u20ac]; exit"
+ close $f
+ catch {set f [open "|[list [interpreter] -encoding utf-8 script]" r]}
+} -body {
+ read $f
+} -cleanup {
+ close $f
+ removeFile script
+} -result "script {} 0\n1\n"
-test main-2.2 {Tk_MainEx: -encoding option} -constraints {
- stdio
- } -setup {
- set script [makeFile {} script]
- file delete $script
- set f [open $script w]
- fconfigure $f -encoding utf-8
- puts $f {puts [list $argv0 $argv $tcl_interactive]}
- puts -nonewline $f {puts [string equal \u20ac }
- puts $f "\u20ac]; exit"
- close $f
- catch {set f [open "|[list [interpreter] -encoding ascii script]" r]}
- } -body {
- read $f
- } -cleanup {
- close $f
- removeFile script
- } -result [list script {} 0]\n0\n
+test main-2.2 {Tk_MainEx: -encoding option} -constraints stdio -setup {
+ set script [makeFile {} script]
+ file delete $script
+ set f [open $script w]
+ fconfigure $f -encoding utf-8
+ puts $f {puts [list $argv0 $argv $tcl_interactive]}
+ puts -nonewline $f {puts [string equal \u20ac }
+ puts $f "\u20ac]; exit"
+ close $f
+ catch {set f [open "|[list [interpreter] -encoding ascii script]" r]}
+} -body {
+ read $f
+} -cleanup {
+ close $f
+ removeFile script
+} -result "script {} 0\n0\n"
- # Procedure to simulate interactive typing of commands, line by line
+ # Procedure to simulate interactive typing of commands, line by line,
+ # for test 2.3
proc type {chan script} {
foreach line [split $script \n] {
if {[catch {
@@ -74,52 +70,50 @@ test main-2.2 {Tk_MainEx: -encoding option} -constraints {
}
}
-test main-2.3 {Tk_MainEx: -encoding option} -constraints {
- stdio
- } -setup {
- set script [makeFile {} script]
- file delete $script
- set f [open $script w]
- fconfigure $f -encoding utf-8
- puts $f {puts [list $argv0 $argv $tcl_interactive]}
- puts -nonewline $f {puts [string equal \u20ac }
- puts $f "\u20ac]"
- close $f
- catch {set f [open "|[list [interpreter] -enc utf-8 script]" r+]}
- } -body {
- type $f {
- puts $argv
- exit
- }
- list [catch {gets $f} line] $line
- } -cleanup {
- close $f
- removeFile script
- } -result {0 {-enc utf-8 script}}
+test main-2.3 {Tk_MainEx: -encoding option} -constraints stdio -setup {
+ set script [makeFile {} script]
+ file delete $script
+ set f [open $script w]
+ fconfigure $f -encoding utf-8
+ puts $f {puts [list $argv0 $argv $tcl_interactive]}
+ puts -nonewline $f {puts [string equal \u20ac }
+ puts $f "\u20ac]"
+ close $f
+ catch {set f [open "|[list [interpreter] -enc utf-8 script]" r+]}
+} -body {
+ type $f {
+ puts $argv
+ exit
+ }
+ gets $f
+} -cleanup {
+ close $f
+ removeFile script
+} -returnCodes ok -result {-enc utf-8 script}
test main-3.1 {Tk_ParseArgv: -help option} -constraints unix -body {
# Run only on unix as Win32 pops up native dialog
- list [catch {exec [interpreter] -help} msg] $msg
-} -match glob -result {1 {% Application initialization failed: Command-specific options:*}}
+ exec [interpreter] -help
+} -returnCodes error -match glob -result {% application-specific initialization failed: Command-specific options:*}
test main-3.2 {Tk_ParseArgv: -help option} -setup {
set maininterp [interp create]
} -body {
$maininterp eval { set argc 1 ; set argv -help }
- list [catch {load {} Tk $maininterp} msg] $msg
+ load {} Tk $maininterp
} -cleanup {
interp delete $maininterp
-} -match glob -result {1 {Command-specific options:*}}
+} -returnCodes error -match glob -result {Command-specific options:*}
test main-3.3 {Tk_ParseArgv: -help option} -setup {
set maininterp [interp create]
} -body {
# Repeat of 3.2 to catch cleanup, eg Bug 1927135
$maininterp eval { set argc 1 ; set argv -help }
- list [catch {load {} Tk $maininterp} msg] $msg
+ load {} Tk $maininterp
} -cleanup {
interp delete $maininterp
-} -match glob -result {1 {Command-specific options:*}}
+} -returnCodes error -match glob -result {Command-specific options:*}
# cleanup
cleanupTests
diff --git a/tests/menu.test b/tests/menu.test
index 3cb47c3..595a21b 100644
--- a/tests/menu.test
+++ b/tests/menu.test
@@ -5,95 +5,103 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
+imageInit
-# find the earth.gif file for use in these tests
+# find the earth.gif file for use in these tests (tests 2.*)
set earthPhotoFile [file join [file dirname [info script]] earth.gif]
testConstraint hasEarthPhoto [file exists $earthPhotoFile]
-test menu-1.1 {Tk_MenuCmd procedure} {
- list [catch menu msg] $msg
-} {1 {wrong # args: should be "menu pathName ?options?"}}
-test menu-1.2 {Tk_MenuCmd procedure} {
- list [catch "menu bogus" msg] $msg
-} {1 {bad window path name "bogus"}}
-test menu-1.3 {Tk_MenuCmd procedure} {
- list [catch "menu .m1 foo" msg] $msg
-} {1 {unknown option "foo"}}
-test menu-1.4 {Tk_MenuCmd procedure} {
- catch {destroy .m1}
- list [catch {menu .m1} msg] $msg [destroy .m1]
-} {0 .m1 {}}
-test menu-1.5 {Tk_MenuCmd - creating menubar} {
- catch {destroy .m1}
+test menu-1.1 {Tk_MenuCmd procedure} -body {
+ menu
+} -returnCodes error -result {wrong # args: should be "menu pathName ?-option value ...?"}
+test menu-1.2 {Tk_MenuCmd procedure} -body {
+ menu bogus
+} -returnCodes error -result {bad window path name "bogus"}
+test menu-1.3 {Tk_MenuCmd procedure} -body {
+ destroy .m1
+ menu .m1 foo
+} -returnCodes error -result {unknown option "foo"}
+test menu-1.4 {Tk_MenuCmd procedure} -body {
+ destroy .m1
+ menu .m1
+} -cleanup {
+ deleteWindows
+} -result {.m1}
+test menu-1.5 {Tk_MenuCmd - creating menubar} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add cascade -label Test -menu ""
- list [. configure -menu .m1] [. configure -menu ""] [destroy .m1]
-} {{} {} {}}
-test menu-1.6 {Tk_MenuCmd procedure menu ref no cascade} {
- catch {destroy .t2}
- catch {destroy .m1}
+ list [. configure -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-1.6 {Tk_MenuCmd procedure menu ref no cascade} -setup {
+ deleteWindows
+} -body {
toplevel .t2 -menu .m1
wm geometry .t2 +0+0
- list [catch {menu .m1} msg] $msg [destroy .m1 .t2]
-} {0 .m1 {}}
-test menu-1.7 {Tk_MenuCmd procedure one clone cascade} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .t2}
+ menu .m1
+} -cleanup {
+ deleteWindows
+} -result {.m1}
+test menu-1.7 {Tk_MenuCmd procedure one clone cascade} -setup {
+ deleteWindows
+} -body {
toplevel .t2 -menu .m1
wm geometry .t2 +0+0
menu .m1
.m1 add cascade -menu .m2
- list [catch {menu .m2} msg] $msg [destroy .t2 .m1 .m2]
-} {0 .m2 {}}
-test menu-1.8 {Tk_MenuCmd procedure two clone cascades} {
- catch {destroy .m1}
- catch {destroy .t2}
- catch {destroy .t3}
- catch {destroy .m2}
+ menu .m2
+} -cleanup {
+ deleteWindows
+} -result {.m2}
+test menu-1.8 {Tk_MenuCmd procedure two clone cascades} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add cascade -menu .m2
toplevel .t2 -menu .m1
wm geometry .t2 +0+0
toplevel .t3 -menu .m1
wm geometry .t3 +0+0
- list [catch {menu .m2} msg] $msg [destroy .t2 .t3 .m1 .m2]
-} {0 .m2 {}}
-test menu-1.9 {Tk_MenuCmd procedure two clone cascades different order} {
- catch {destroy .t2}
- catch {destroy .m1}
- catch {destroy .t3}
- catch {destroy .m2}
+ menu .m2
+} -cleanup {
+ deleteWindows
+} -result {.m2}
+test menu-1.9 {Tk_MenuCmd procedure two clone cascades different order} -setup {
+ deleteWindows
+} -body {
toplevel .t2 -menu .m1
wm geometry .t2 +0+0
menu .m1
.m1 add cascade -menu .m2
toplevel .t3 -menu .m1
wm geometry .t3 +0+0
- list [catch {menu .m2} msg] $msg [destroy .t2 .t3 .m1 .m2]
-} {0 .m2 {}}
-test menu-1.10 {Tk_MenuCmd procedure two clone cascades menus last} {
- catch {destroy .t2}
- catch {destroy .t3}
- catch {destroy .m1}
- catch {destroy .m2}
+ list [menu .m2]
+} -cleanup {
+ deleteWindows
+} -result {.m2}
+test menu-1.10 {Tk_MenuCmd procedure two clone cascades menus last} -setup {
+ deleteWindows
+} -body {
toplevel .t2 -menu .m1
wm geometry .t2 +0+0
toplevel .t3 -menu .m1
wm geometry .t3 +0+0
menu .m1
.m1 add cascade -menu .m2
- list [catch {menu .m2} msg] $msg [destroy .t2 .t3 .m1 .m2]
-} {0 .m2 {}}
-test menu-1.11 {Tk_MenuCmd procedure three clones cascades} {
- catch {destroy .t2}
- catch {destroy .t3}
- catch {destroy .t4}
- catch {destroy .m1}
- catch {destroy .m2}
+ list [menu .m2]
+} -cleanup {
+ deleteWindows
+} -result {.m2}
+test menu-1.11 {Tk_MenuCmd procedure three clones cascades} -setup {
+ deleteWindows
+} -body {
toplevel .t2 -menu .m1
wm geometry .t2 +0+0
toplevel .t3 -menu .m1
@@ -102,93 +110,175 @@ test menu-1.11 {Tk_MenuCmd procedure three clones cascades} {
wm geometry .t4 +0+0
menu .m1
.m1 add cascade -menu .m2
- list [catch {menu .m2} msg] $msg [destroy .t2 .t3 .t4 .m1 .m2]
-} {0 .m2 {}}
-test menu-1.12 {Tk_MenuCmd procedure} {
- catch {destroy .t2}
- catch {destroy .m1}
+ list [menu .m2]
+} -cleanup {
+ deleteWindows
+} -result {.m2}
+test menu-1.12 {Tk_MenuCmd procedure} -setup {
+ deleteWindows
+} -body {
toplevel .t2 -menu .m1
wm geometry .t2 +0+0
- list [catch {menu .m1} msg] $msg [destroy .t2 .m1]
-} {0 .m1 {}}
-test menu-1.13 {Tk_MenuCmd procedure} {
- catch {destroy .t2}
- catch {destroy .t3}
- catch {destroy .m1}
+ list [menu .m1]
+} -cleanup {
+ deleteWindows
+} -result {.m1}
+test menu-1.13 {Tk_MenuCmd procedure} -setup {
+ deleteWindows
+} -body {
toplevel .t2 -menu .m1
wm geometry .t2 +0+0
toplevel .t3 -menu .m1
wm geometry .t3 +0+0
- list [catch {menu .m1} msg] $msg [destroy .t2 .t3 .m1]
-} {0 .m1 {}}
-test menu-1.14 {Tk_MenuCmd procedure} {
- catch {destroy .t2}
- catch {destroy .t3}
- catch {destroy .t4}
- catch {destroy .m1}
+ list [menu .m1]
+} -cleanup {
+ deleteWindows
+} -result {.m1}
+test menu-1.14 {Tk_MenuCmd procedure} -setup {
+ deleteWindows
+} -body {
toplevel .t2 -menu .m1
wm geometry .t2 +0+0
toplevel .t3 -menu .m1
wm geometry .t3 +0+0
toplevel .t4 -menu .m1
wm geometry .t4 +0+0
- list [catch {menu .m1} msg] $msg [destroy .t2 .t3 .t4 .m1]
-} {0 .m1 {}}
+ list [menu .m1]
+} -cleanup {
+ deleteWindows
+} -result {.m1}
-catch {destroy .m1}
+# Used for 2.1 - 2.30 tests
+destroy .m1
menu .m1
-set i 1
-foreach configTest {
- {-activebackground #012345 #012345 non-existent
- {unknown color name "non-existent"}}
- {-activeborderwidth 1.3 1.3 badValue {bad screen distance "badValue"}}
- {-activeforeground #ff0000 #ff0000 non-existent
- {unknown color name "non-existent"}}
- {-background #ff0000 #ff0000 non-existent
- {unknown color name "non-existent"}}
- {-bg #110022 #110022 bogus {unknown color name "bogus"}}
- {-borderwidth 1.3 1.3 badValue {bad screen distance "badValue"}}
- {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
- {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"}}
- {-fg #110022 #110022 bogus {unknown color name "bogus"}}
- {-font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
- -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* {}
- {font "" doesn't exist}}
- {-foreground #110022 #110022 bogus {unknown color name "bogus"}}
- {-postcommand "any old string" "any old string" {} {}}
- {-relief groove groove 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}}
- {-selectcolor #110022 #110022 bogus {unknown color name "bogus"}}
- {-takefocus "any string" "any string" {} {}}
- {-tearoff 0 0}
- {-tearoff 1 1}
- {-tearoffcommand "any old string" "any old string" {} {}}
-} {
- set name [lindex $configTest 0]
- set value [lindex $configTest 1]
- set result [lindex $configTest 2]
- test menu-2.$i [list configuration options $name $value $result] {
- .m1 configure $name $value
- lindex [.m1 configure $name] 4
- } $result
- incr i
- if {[lindex $configTest 3] != ""} {
- set value [lindex $configTest 3]
- set result [lindex $configTest 4]
- test menu-2.$i [list configuration options $name $value $result] {
- list [catch {.m1 configure $name $value} msg] $msg
- } [list 1 $result]
- }
- .m1 configure $name [lindex [.m1 configure $name] 3]
- incr i
-}
+test menu-2.1 {configuration options -activebackground #012345} -body {
+ .m1 configure -activebackground #012345
+ .m1 cget -activebackground
+} -result {#012345}
+test menu-2.2 {configuration options -activebackground non-existent} -body {
+ .m1 configure -activebackground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.3 {configuration options -activeborderwidth 1.3} -body {
+ .m1 configure -activeborderwidth 1.3
+ .m1 cget -activeborderwidth
+} -result {1.3}
+test menu-2.4 {configuration options -activeborderwidth badValue} -body {
+ .m1 configure -activeborderwidth badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+
+test menu-2.5 {configuration options -activeforeground #ff0000} -body {
+ .m1 configure -activeforeground #ff0000
+ .m1 cget -activeforeground
+} -result {#ff0000}
+test menu-2.6 {configuration options -activeforeground non-existent} -body {
+ .m1 configure -activeforeground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.7 {configuration options -background #ff0000} -body {
+ .m1 configure -background #ff0000
+ .m1 cget -background
+} -result {#ff0000}
+test menu-2.8 {configuration options -background non-existent} -body {
+ .m1 configure -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.9 {configuration options -bg #110022} -body {
+ .m1 configure -bg #110022
+ .m1 cget -bg
+} -result {#110022}
+test menu-2.10 {configuration options -bg bogus} -body {
+ .m1 configure -bg bogus
+} -returnCodes error -result {unknown color name "bogus"}
+
+test menu-2.11 {configuration options -borderwidth 1.3} -body {
+ .m1 configure -borderwidth 1.3
+ .m1 cget -borderwidth
+} -result {1.3}
+test menu-2.12 {configuration options -borderwidth badValue} -body {
+ .m1 configure -borderwidth badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+
+test menu-2.13 {configuration options -cursor arrow} -body {
+ .m1 configure -cursor arrow
+ .m1 cget -cursor
+} -result {arrow}
+test menu-2.14 {configuration options -cursor badValue} -body {
+ .m1 configure -cursor badValue
+} -returnCodes error -result {bad cursor spec "badValue"}
+
+test menu-2.15 {configuration options -disabledforeground #00ff00} -body {
+ .m1 configure -disabledforeground #00ff00
+ .m1 cget -disabledforeground
+} -result {#00ff00}
+test menu-2.16 {configuration options -disabledforeground xyzzy} -body {
+ .m1 configure -disabledforeground xyzzy
+} -returnCodes error -result {unknown color name "xyzzy"}
+
+test menu-2.17 {configuration options -fg #110022} -body {
+ .m1 configure -fg #110022
+ .m1 cget -fg
+} -result {#110022}
+test menu-2.18 {configuration options -fg bogus} -body {
+ .m1 configure -fg bogus
+} -returnCodes error -result {unknown color name "bogus"}
+
+test menu-2.19 {configuration options -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*} -body {
+ .m1 configure -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
+ .m1 cget -font
+} -result {-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*}
+test menu-2.20 {configuration options -foreground #110022} -body {
+ .m1 configure -foreground #110022
+ .m1 cget -foreground
+} -result {#110022}
+test menu-2.21 {configuration options -foreground bogus} -body {
+ .m1 configure -foreground bogus
+} -returnCodes error -result {unknown color name "bogus"}
+
+test menu-2.22 {configuration options -postcommand {any old string}} -body {
+ .m1 configure -postcommand {any old string}
+ .m1 cget -postcommand
+} -result {any old string}
+test menu-2.23 {configuration options -relief groove} -body {
+ .m1 configure -relief groove
+ .m1 cget -relief
+} -result {groove}
+test menu-2.24 {configuration options -relief 1.5} -body {
+ .m1 configure -relief 1.5
+} -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+
+test menu-2.25 {configuration options -selectcolor #110022} -body {
+ .m1 configure -selectcolor #110022
+ .m1 cget -selectcolor
+} -result {#110022}
+test menu-2.26 {configuration options -selectcolor bogus} -body {
+ .m1 configure -selectcolor bogus
+} -returnCodes error -result {unknown color name "bogus"}
+
+test menu-2.27 {configuration options -takefocus {any string}} -body {
+ .m1 configure -takefocus {any string}
+ .m1 cget -takefocus
+} -result {any string}
+test menu-2.28 {configuration options -tearoff 0} -body {
+ .m1 configure -tearoff 0
+ .m1 cget -tearoff
+} -result {0}
+test menu-2.29 {configuration options -tearoff 1} -body {
+ .m1 configure -tearoff 1
+ .m1 cget -tearoff
+} -result {1}
+test menu-2.30 {configuration options -tearoffcommand {any old string}} -body {
+ .m1 configure -tearoffcommand {any old string}
+ .m1 cget -tearoffcommand
+} -result {any old string}
destroy .m1
# We need to test all of the options with all of the different types of
# menu entries. The following code sets up .m1 with 6 items. It then
-# runs through the big table below it.
+# runs through the 2.31 - 2.228 tests below
# index 0 is tearoff, 1 command, 2 cascade, 3 separator, 4 checkbutton,
# 5 radiobutton
-
+deleteWindows
menu .m1
.m1 add command -label "command"
menu .m2
@@ -197,488 +287,1172 @@ menu .m2
.m1 add separator
.m1 add checkbutton -label "checkbutton" -variable check -onvalue on -offvalue off
.m1 add radiobutton -label "radiobutton" -variable radio
+
if {[testConstraint hasEarthPhoto]} {
image create photo image1 -file $earthPhotoFile
}
-foreach configTest {
- {-activebackground
- {{#012345
- {{unknown option "-activebackground"} #012345 #012345
- {unknown option "-activebackground"} #012345 #012345
- }
- }
- {non-existent
- {{unknown option "-activebackground"}
- {unknown color name "non-existent"}
- {unknown color name "non-existent"}
- {unknown option "-activebackground"}
- {unknown color name "non-existent"}
- {unknown color name "non-existent"}
- }
- }}
- }
- {-activeforeground
- {{#ff0000
- {{unknown option "-activeforeground"}
- #ff0000 #ff0000 {unknown option "-activeforeground"} #ff0000 #ff0000
- }
- }
- {non-existent
- {{unknown option "-activeforeground"}
- {unknown color name "non-existent"}
- {unknown color name "non-existent"}
- {unknown option "-activeforeground"}
- {unknown color name "non-existent"}
- {unknown color name "non-existent"}
- }
- }}
- }
- {-accelerator
- {{"Ctrl+S"
- {{unknown option "-accelerator"}
- "Ctrl+S" "Ctrl+S" {unknown option "-accelerator"}
- "Ctrl+S" "Ctrl+S"
- }
- }}
- }
- {-background
- {{#ff0000
- {#ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000
- }
- }
- {non-existent
- {{unknown color name "non-existent"}
- {unknown color name "non-existent"}
- {unknown color name "non-existent"}
- {unknown color name "non-existent"}
- {unknown color name "non-existent"}
- {unknown color name "non-existent"}
- }
- }}
- }
- {-bitmap
- {{questhead
- {{unknown option "-bitmap"} questhead questhead
- {unknown option "-bitmap"} questhead questhead
- }
- }
- {badValue
- {{unknown option "-bitmap"}
- {bitmap "badValue" not defined}
- {bitmap "badValue" not defined}
- {unknown option "-bitmap"}
- {bitmap "badValue" not defined}
- {bitmap "badValue" not defined}
- }
- }}
- }
- {-columnbreak
- {{1
- {{unknown option "-columnbreak"} 1 1
- {unknown option "-columnbreak"} 1 1}
- }}
- }
- {-command
- {{beep
- {{unknown option "-command"} beep beep
- {unknown option "-command"} beep beep
- }
- }}
- }
- {-font
- {{-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
- {{unknown option "-font"}
- -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
- -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
- {unknown option "-font"}
- -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
- -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
- }
- }
- {{kill rock stars}
- {{unknown option "-font"}
- {expected integer but got "rock"}
- {expected integer but got "rock"}
- {unknown option "-font"}
- {expected integer but got "rock"}
- {expected integer but got "rock"}
- }
- }}
- }
- {-foreground
- {{#110022
- {{unknown option "-foreground"} #110022 #110022
- {unknown option "-foreground"} #110022 #110022
- }
- }
- {non-existent
- {{unknown option "-foreground"}
- {unknown color name "non-existent"}
- {unknown color name "non-existent"}
- {unknown option "-foreground"}
- {unknown color name "non-existent"}
- {unknown color name "non-existent"}
- }
- }}
- }
- {-image
- {{image1
- {{unknown option "-image"} image1 image1
- {unknown option "-image"} image1 image1
- }
- }
- {bogus
- {{unknown option "-image"}
- {image "bogus" doesn't exist}
- {image "bogus" doesn't exist}
- {unknown option "-image"}
- {image "bogus" doesn't exist}
- {image "bogus" doesn't exist}
- }
- }
- {""
- {{unknown option "-image"}
- {}
- {}
- {unknown option "-image"}
- {}
- {}
- }
- }}
- }
- {-indicatoron
- {{1
- {{unknown option "-indicatoron"}
- {unknown option "-indicatoron"}
- {unknown option "-indicatoron"}
- {unknown option "-indicatoron"} 1 1
- }
- }}
- }
- {-label
- {{test
- {{unknown option "-label"} test test
- {unknown option "-label"} test test
- }
- }}
- }
- {-menu
- {{.m2
- {{unknown option "-menu"}
- {unknown option "-menu"} .m2
- {unknown option "-menu"}
- {unknown option "-menu"}
- {unknown option "-menu"}
- }
- }}
- }
- {-offvalue
- {{off
- {{unknown option "-offvalue"}
- {unknown option "-offvalue"}
- {unknown option "-offvalue"}
- {unknown option "-offvalue"}
- off
- {unknown option "-offvalue"}
- }
- }}
- }
- {-onvalue
- {{on
- {{unknown option "-onvalue"}
- {unknown option "-onvalue"}
- {unknown option "-onvalue"}
- {unknown option "-onvalue"}
- on
- {unknown option "-onvalue"}
- }
- }}
- }
- {-selectcolor
- {{#110022
- {{unknown option "-selectcolor"}
- {unknown option "-selectcolor"}
- {unknown option "-selectcolor"}
- {unknown option "-selectcolor"}
- #110022
- #110022
- }
- }
- {non-existent
- {{unknown option "-selectcolor"}
- {unknown option "-selectcolor"}
- {unknown option "-selectcolor"}
- {unknown option "-selectcolor"}
- {unknown color name "non-existent"}
- {unknown color name "non-existent"}
- }
- }}
- }
- {-selectimage
- {{image1
- {{unknown option "-selectimage"}
- {unknown option "-selectimage"}
- {unknown option "-selectimage"}
- {unknown option "-selectimage"} image1 image1
- }
- }
- {bogus
- {{unknown option "-selectimage"}
- {unknown option "-selectimage"}
- {unknown option "-selectimage"}
- {unknown option "-selectimage"}
- {image "bogus" doesn't exist}
- {image "bogus" doesn't exist}
- }
- }
- {""
- {{unknown option "-selectimage"}
- {unknown option "-selectimage"}
- {unknown option "-selectimage"}
- {unknown option "-selectimage"}
- {}
- {}
- }
- }}
- }
- {-state
- {{normal
- {normal normal normal {unknown option "-state"} normal normal
- }
- }}
- }
- {-value
- {{"any string"
- {{unknown option "-value"}
- {unknown option "-value"}
- {unknown option "-value"}
- {unknown option "-value"}
- {unknown option "-value"} "any string"
- }
- }}
- }
- {-variable
- {{"any string"
- {{unknown option "-variable"}
- {unknown option "-variable"}
- {unknown option "-variable"}
- {unknown option "-variable"}
- "any string"
- "any string"
- }
- }}
- }
- {-underline
- {{0
- {{unknown option "-underline"} 0 0
- {unknown option "-underline"} 0 0
- }
- }
- {3p
- {{unknown option "-underline"}
- {expected integer but got "3p"}
- {expected integer but got "3p"}
- {unknown option "-underline"}
- {expected integer but got "3p"}
- {expected integer but got "3p"}
- }
- }}
- }
-} {
- set name [lindex $configTest 0]
- foreach attempt [lindex $configTest 1] {
- set value [lindex $attempt 0]
- set options [lindex $attempt 1]
- foreach item {0 1 2 3 4 5} {
- catch {unset msg}
- # OK, it's an overeager constraint, but it should also
- # normally hold anyway
- test menu-2.$i [list entry configuration options $name $item $value [.m1 type $item]] hasEarthPhoto {
- set result [catch {.m1 entryconfigure $item $name $value} msg]
- if {$result == 1} {
- set msg
- } else {
- lindex [.m1 entryconfigure $item $name] 4
- }
- } [lindex $options $item]
- incr i
- }
- }
-}
+test menu-2.31 {entry configuration options 0 -activebackground #012345 tearoff} -body {
+ .m1 entryconfigure 0 -activebackground #012345
+} -returnCodes error -result {unknown option "-activebackground"}
+
+test menu-2.32 {entry configuration options 1 -activebackground #012345 command} -body {
+ .m1 entryconfigure 1 -activebackground #012345
+ lindex [.m1 entryconfigure 1 -activebackground] 4
+} -result {#012345}
+
+test menu-2.33 {entry configuration options 2 -activebackground #012345 cascade} -body {
+ .m1 entryconfigure 2 -activebackground #012345
+ lindex [.m1 entryconfigure 2 -activebackground] 4
+} -result {#012345}
+
+test menu-2.34 {entry configuration options 3 -activebackground #012345 separator} -body {
+ .m1 entryconfigure 3 -activebackground #012345
+} -returnCodes error -result {unknown option "-activebackground"}
+
+test menu-2.35 {entry configuration options 4 -activebackground #012345 checkbutton} -body {
+ .m1 entryconfigure 4 -activebackground #012345
+ lindex [.m1 entryconfigure 4 -activebackground] 4
+} -result {#012345}
+
+test menu-2.36 {entry configuration options 5 -activebackground #012345 radiobutton} -body {
+ .m1 entryconfigure 5 -activebackground #012345
+ lindex [.m1 entryconfigure 5 -activebackground] 4
+} -result {#012345}
+
+test menu-2.37 {entry configuration options 0 -activebackground non-existent tearoff} -body {
+ .m1 entryconfigure 0 -activebackground non-existent
+} -returnCodes error -result {unknown option "-activebackground"}
+
+test menu-2.38 {entry configuration options 1 -activebackground non-existent command} -body {
+ .m1 entryconfigure 1 -activebackground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.39 {entry configuration options 2 -activebackground non-existent cascade} -body {
+ .m1 entryconfigure 2 -activebackground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.40 {entry configuration options 3 -activebackground non-existent separator} -body {
+ .m1 entryconfigure 3 -activebackground non-existent
+} -returnCodes error -result {unknown option "-activebackground"}
+
+test menu-2.41 {entry configuration options 4 -activebackground non-existent checkbutton} -body {
+ .m1 entryconfigure 4 -activebackground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.42 {entry configuration options 5 -activebackground non-existent radiobutton} -body {
+ .m1 entryconfigure 5 -activebackground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.43 {entry configuration options 0 -activeforeground #ff0000 tearoff} -body {
+ .m1 entryconfigure 0 -activeforeground #ff0000
+} -returnCodes error -result {unknown option "-activeforeground"}
+
+test menu-2.44 {entry configuration options 1 -activeforeground #ff0000 command} -body {
+ .m1 entryconfigure 1 -activeforeground #ff0000
+ lindex [.m1 entryconfigure 1 -activeforeground] 4
+} -result {#ff0000}
+
+test menu-2.45 {entry configuration options 2 -activeforeground #ff0000 cascade} -body {
+ .m1 entryconfigure 2 -activeforeground #ff0000
+ lindex [.m1 entryconfigure 2 -activeforeground] 4
+} -result {#ff0000}
+
+test menu-2.46 {entry configuration options 3 -activeforeground #ff0000 separator} -body {
+ .m1 entryconfigure 3 -activeforeground #ff0000
+} -returnCodes error -result {unknown option "-activeforeground"}
+
+test menu-2.47 {entry configuration options 4 -activeforeground #ff0000 checkbutton} -body {
+ .m1 entryconfigure 4 -activeforeground #ff0000
+ lindex [.m1 entryconfigure 4 -activeforeground] 4
+} -result {#ff0000}
+
+test menu-2.48 {entry configuration options 5 -activeforeground #ff0000 radiobutton} -body {
+ .m1 entryconfigure 5 -activeforeground #ff0000
+ lindex [.m1 entryconfigure 5 -activeforeground] 4
+} -result {#ff0000}
+
+test menu-2.49 {entry configuration options 0 -activeforeground non-existent tearoff} -body {
+ .m1 entryconfigure 0 -activeforeground non-existent
+} -returnCodes error -result {unknown option "-activeforeground"}
+
+test menu-2.50 {entry configuration options 1 -activeforeground non-existent command} -body {
+ .m1 entryconfigure 1 -activeforeground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.51 {entry configuration options 2 -activeforeground non-existent cascade} -body {
+ .m1 entryconfigure 2 -activeforeground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.52 {entry configuration options 3 -activeforeground non-existent separator} -body {
+ .m1 entryconfigure 3 -activeforeground non-existent
+} -returnCodes error -result {unknown option "-activeforeground"}
+
+test menu-2.53 {entry configuration options 4 -activeforeground non-existent checkbutton} -body {
+ .m1 entryconfigure 4 -activeforeground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.54 {entry configuration options 5 -activeforeground non-existent radiobutton} -body {
+ .m1 entryconfigure 5 -activeforeground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.55 {entry configuration options 0 -accelerator Ctrl+S tearoff} -body {
+ .m1 entryconfigure 0 -accelerator Ctrl+S
+} -returnCodes error -result {unknown option "-accelerator"}
+
+test menu-2.56 {entry configuration options 1 -accelerator Ctrl+S command} -body {
+ .m1 entryconfigure 1 -accelerator Ctrl+S
+ lindex [.m1 entryconfigure 1 -accelerator] 4
+} -result {Ctrl+S}
+
+test menu-2.57 {entry configuration options 2 -accelerator Ctrl+S cascade} -body {
+ .m1 entryconfigure 2 -accelerator Ctrl+S
+ lindex [.m1 entryconfigure 2 -accelerator] 4
+} -result {Ctrl+S}
+
+test menu-2.58 {entry configuration options 3 -accelerator Ctrl+S separator} -body {
+ .m1 entryconfigure 3 -accelerator Ctrl+S
+} -returnCodes error -result {unknown option "-accelerator"}
+
+test menu-2.59 {entry configuration options 4 -accelerator Ctrl+S checkbutton} -body {
+ .m1 entryconfigure 4 -accelerator Ctrl+S
+ lindex [.m1 entryconfigure 4 -accelerator] 4
+} -result {Ctrl+S}
+
+test menu-2.60 {entry configuration options 5 -accelerator Ctrl+S radiobutton} -body {
+ .m1 entryconfigure 5 -accelerator Ctrl+S
+ lindex [.m1 entryconfigure 5 -accelerator] 4
+} -result {Ctrl+S}
+
+test menu-2.61 {entry configuration options 0 -background #ff0000 tearoff} -body {
+ .m1 entryconfigure 0 -background #ff0000
+ lindex [.m1 entryconfigure 0 -background] 4
+} -result {#ff0000}
+
+test menu-2.62 {entry configuration options 1 -background #ff0000 command} -body {
+ .m1 entryconfigure 1 -background #ff0000
+ lindex [.m1 entryconfigure 1 -background] 4
+} -result {#ff0000}
+
+test menu-2.63 {entry configuration options 2 -background #ff0000 cascade} -body {
+ .m1 entryconfigure 2 -background #ff0000
+ lindex [.m1 entryconfigure 2 -background] 4
+} -result {#ff0000}
+
+test menu-2.64 {entry configuration options 3 -background #ff0000 separator} -body {
+ .m1 entryconfigure 3 -background #ff0000
+ lindex [.m1 entryconfigure 3 -background] 4
+} -result {#ff0000}
+
+test menu-2.65 {entry configuration options 4 -background #ff0000 checkbutton} -body {
+ .m1 entryconfigure 4 -background #ff0000
+ lindex [.m1 entryconfigure 4 -background] 4
+} -result {#ff0000}
+
+test menu-2.66 {entry configuration options 5 -background #ff0000 radiobutton} -body {
+ .m1 entryconfigure 5 -background #ff0000
+ lindex [.m1 entryconfigure 5 -background] 4
+} -result {#ff0000}
+
+test menu-2.67 {entry configuration options 0 -background non-existent tearoff} -body {
+ .m1 entryconfigure 0 -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.68 {entry configuration options 1 -background non-existent command} -body {
+ .m1 entryconfigure 1 -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.69 {entry configuration options 2 -background non-existent cascade} -body {
+ .m1 entryconfigure 2 -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.70 {entry configuration options 3 -background non-existent separator} -body {
+ .m1 entryconfigure 3 -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.71 {entry configuration options 4 -background non-existent checkbutton} -body {
+ .m1 entryconfigure 4 -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.72 {entry configuration options 5 -background non-existent radiobutton} -body {
+ .m1 entryconfigure 5 -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.73 {entry configuration options 0 -bitmap questhead tearoff} -body {
+ .m1 entryconfigure 0 -bitmap questhead
+} -returnCodes error -result {unknown option "-bitmap"}
+
+test menu-2.74 {entry configuration options 1 -bitmap questhead command} -body {
+ .m1 entryconfigure 1 -bitmap questhead
+ lindex [.m1 entryconfigure 1 -bitmap] 4
+} -result {questhead}
+
+test menu-2.75 {entry configuration options 2 -bitmap questhead cascade} -body {
+ .m1 entryconfigure 2 -bitmap questhead
+ lindex [.m1 entryconfigure 2 -bitmap] 4
+} -result {questhead}
+
+test menu-2.76 {entry configuration options 3 -bitmap questhead separator} -body {
+ .m1 entryconfigure 3 -bitmap questhead
+} -returnCodes error -result {unknown option "-bitmap"}
+
+test menu-2.77 {entry configuration options 4 -bitmap questhead checkbutton} -body {
+ .m1 entryconfigure 4 -bitmap questhead
+ lindex [.m1 entryconfigure 4 -bitmap] 4
+} -result {questhead}
+
+test menu-2.78 {entry configuration options 5 -bitmap questhead radiobutton} -body {
+ .m1 entryconfigure 5 -bitmap questhead
+ lindex [.m1 entryconfigure 5 -bitmap] 4
+} -result {questhead}
+
+test menu-2.79 {entry configuration options 0 -bitmap badValue tearoff} -body {
+ .m1 entryconfigure 0 -bitmap badValue
+} -returnCodes error -result {unknown option "-bitmap"}
+
+test menu-2.80 {entry configuration options 1 -bitmap badValue command} -body {
+ .m1 entryconfigure 1 -bitmap badValue
+} -returnCodes error -result {bitmap "badValue" not defined}
+
+test menu-2.81 {entry configuration options 2 -bitmap badValue cascade} -body {
+ .m1 entryconfigure 2 -bitmap badValue
+} -returnCodes error -result {bitmap "badValue" not defined}
+
+test menu-2.82 {entry configuration options 3 -bitmap badValue separator} -body {
+ .m1 entryconfigure 3 -bitmap badValue
+} -returnCodes error -result {unknown option "-bitmap"}
+
+test menu-2.83 {entry configuration options 4 -bitmap badValue checkbutton} -body {
+ .m1 entryconfigure 4 -bitmap badValue
+} -returnCodes error -result {bitmap "badValue" not defined}
+
+test menu-2.84 {entry configuration options 5 -bitmap badValue radiobutton} -body {
+ .m1 entryconfigure 5 -bitmap badValue
+} -returnCodes error -result {bitmap "badValue" not defined}
+
+test menu-2.85 {entry configuration options 0 -columnbreak 1 tearoff} -body {
+ .m1 entryconfigure 0 -columnbreak 1
+} -returnCodes error -result {unknown option "-columnbreak"}
+test menu-2.86 {entry configuration options 1 -columnbreak 1 command} -body {
+ .m1 entryconfigure 1 -columnbreak 1
+ lindex [.m1 entryconfigure 1 -columnbreak] 4
+} -result {1}
+
+test menu-2.87 {entry configuration options 2 -columnbreak 1 cascade} -body {
+ .m1 entryconfigure 2 -columnbreak 1
+ lindex [.m1 entryconfigure 2 -columnbreak] 4
+} -result {1}
+
+test menu-2.88 {entry configuration options 3 -columnbreak 1 separator} -body {
+ .m1 entryconfigure 3 -columnbreak 1
+} -returnCodes error -result {unknown option "-columnbreak"}
+
+test menu-2.89 {entry configuration options 4 -columnbreak 1 checkbutton} -body {
+ .m1 entryconfigure 4 -columnbreak 1
+ lindex [.m1 entryconfigure 4 -columnbreak] 4
+} -result {1}
+
+test menu-2.90 {entry configuration options 5 -columnbreak 1 radiobutton} -body {
+ .m1 entryconfigure 5 -columnbreak 1
+ lindex [.m1 entryconfigure 5 -columnbreak] 4
+} -result {1}
+
+test menu-2.91 {entry configuration options 0 -command beep tearoff} -body {
+ .m1 entryconfigure 0 -command beep
+} -returnCodes error -result {unknown option "-command"}
+
+test menu-2.92 {entry configuration options 1 -command beep command} -body {
+ .m1 entryconfigure 1 -command beep
+ lindex [.m1 entryconfigure 1 -command] 4
+} -result {beep}
+
+test menu-2.93 {entry configuration options 2 -command beep cascade} -body {
+ .m1 entryconfigure 2 -command beep
+ lindex [.m1 entryconfigure 2 -command] 4
+} -result {beep}
+
+test menu-2.94 {entry configuration options 3 -command beep separator} -body {
+ .m1 entryconfigure 3 -command beep
+} -returnCodes error -result {unknown option "-command"}
+
+test menu-2.95 {entry configuration options 4 -command beep checkbutton} -body {
+ .m1 entryconfigure 4 -command beep
+ lindex [.m1 entryconfigure 4 -command] 4
+} -result {beep}
+
+test menu-2.96 {entry configuration options 5 -command beep radiobutton} -body {
+ .m1 entryconfigure 5 -command beep
+ lindex [.m1 entryconfigure 5 -command] 4
+} -result {beep}
+
+test menu-2.97 {entry configuration options 0 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* tearoff} -body {
+ .m1 entryconfigure 0 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
+} -returnCodes error -result {unknown option "-font"}
+
+test menu-2.98 {entry configuration options 1 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* command} -body {
+ .m1 entryconfigure 1 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
+ lindex [.m1 entryconfigure 1 -font] 4
+} -result {-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*}
+
+test menu-2.99 {entry configuration options 2 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* cascade} -body {
+ .m1 entryconfigure 2 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
+ lindex [.m1 entryconfigure 2 -font] 4
+} -result {-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*}
+
+test menu-2.100 {entry configuration options 3 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* separator} -body {
+ .m1 entryconfigure 3 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
+} -returnCodes error -result {unknown option "-font"}
+
+test menu-2.101 {entry configuration options 4 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* checkbutton} -body {
+ .m1 entryconfigure 4 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
+ lindex [.m1 entryconfigure 4 -font] 4
+} -result {-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*}
+
+test menu-2.102 {entry configuration options 5 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* radiobutton} -body {
+ .m1 entryconfigure 5 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
+ lindex [.m1 entryconfigure 5 -font] 4
+} -result {-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*}
+
+test menu-2.103 {entry configuration options 0 -font {kill rock stars} tearoff} -body {
+ .m1 entryconfigure 0 -font {kill rock stars}
+} -returnCodes error -result {unknown option "-font"}
+
+test menu-2.104 {entry configuration options 1 -font {kill rock stars} command} -body {
+ .m1 entryconfigure 1 -font {kill rock stars}
+} -returnCodes error -result {expected integer but got "rock"}
+
+test menu-2.105 {entry configuration options 2 -font {kill rock stars} cascade} -body {
+ .m1 entryconfigure 2 -font {kill rock stars}
+} -returnCodes error -result {expected integer but got "rock"}
+
+test menu-2.106 {entry configuration options 3 -font {kill rock stars} separator} -body {
+ .m1 entryconfigure 3 -font {kill rock stars}
+} -returnCodes error -result {unknown option "-font"}
+
+test menu-2.107 {entry configuration options 4 -font {kill rock stars} checkbutton} -body {
+ .m1 entryconfigure 4 -font {kill rock stars}
+} -returnCodes error -result {expected integer but got "rock"}
+
+test menu-2.108 {entry configuration options 5 -font {kill rock stars} radiobutton} -body {
+ .m1 entryconfigure 5 -font {kill rock stars}
+} -returnCodes error -result {expected integer but got "rock"}
+
+test menu-2.109 {entry configuration options 0 -foreground #110022 tearoff} -body {
+ .m1 entryconfigure 0 -foreground #110022
+} -returnCodes error -result {unknown option "-foreground"}
+
+test menu-2.110 {entry configuration options 1 -foreground #110022 command} -body {
+ .m1 entryconfigure 1 -foreground #110022
+ lindex [.m1 entryconfigure 1 -foreground] 4
+} -result {#110022}
+
+test menu-2.111 {entry configuration options 2 -foreground #110022 cascade} -body {
+ .m1 entryconfigure 2 -foreground #110022
+ lindex [.m1 entryconfigure 2 -foreground] 4
+} -result {#110022}
+
+test menu-2.112 {entry configuration options 3 -foreground #110022 separator} -body {
+ .m1 entryconfigure 3 -foreground #110022
+} -returnCodes error -result {unknown option "-foreground"}
+
+test menu-2.113 {entry configuration options 4 -foreground #110022 checkbutton} -body {
+ .m1 entryconfigure 4 -foreground #110022
+ lindex [.m1 entryconfigure 4 -foreground] 4
+} -result {#110022}
+
+test menu-2.114 {entry configuration options 5 -foreground #110022 radiobutton} -body {
+ .m1 entryconfigure 5 -foreground #110022
+ lindex [.m1 entryconfigure 5 -foreground] 4
+} -result {#110022}
+
+test menu-2.115 {entry configuration options 0 -foreground non-existent tearoff} -body {
+ .m1 entryconfigure 0 -foreground non-existent
+} -returnCodes error -result {unknown option "-foreground"}
+
+test menu-2.116 {entry configuration options 1 -foreground non-existent command} -body {
+ .m1 entryconfigure 1 -foreground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.117 {entry configuration options 2 -foreground non-existent cascade} -body {
+ .m1 entryconfigure 2 -foreground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.118 {entry configuration options 3 -foreground non-existent separator} -body {
+ .m1 entryconfigure 3 -foreground non-existent
+} -returnCodes error -result {unknown option "-foreground"}
+
+test menu-2.119 {entry configuration options 4 -foreground non-existent checkbutton} -body {
+ .m1 entryconfigure 4 -foreground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.120 {entry configuration options 5 -foreground non-existent radiobutton} -body {
+ .m1 entryconfigure 5 -foreground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.121 {entry configuration options 0 -image image1 tearoff} -constraints {
+ hasEarthPhoto
+} -body {
+ .m1 entryconfigure 0 -image image1
+} -returnCodes error -result {unknown option "-image"}
+
+test menu-2.122 {entry configuration options 1 -image image1 command} -constraints {
+ hasEarthPhoto
+} -setup {
+ .m1 entryconfigure 1 -image {}
+} -body {
+ .m1 entryconfigure 1 -image image1
+ lindex [.m1 entryconfigure 1 -image] 4
+} -cleanup {
+ .m1 entryconfigure 1 -image {}
+} -result {image1}
+
+test menu-2.123 {entry configuration options 2 -image image1 cascade} -constraints {
+ hasEarthPhoto
+} -setup {
+ .m1 entryconfigure 2 -image {}
+} -body {
+ .m1 entryconfigure 2 -image image1
+ lindex [.m1 entryconfigure 2 -image] 4
+} -cleanup {
+ .m1 entryconfigure 2 -image {}
+} -result {image1}
+
+test menu-2.124 {entry configuration options 3 -image image1 separator} -constraints {
+ hasEarthPhoto
+} -body {
+ .m1 entryconfigure 3 -image image1
+} -returnCodes error -result {unknown option "-image"}
+
+test menu-2.125 {entry configuration options 4 -image image1 checkbutton} -constraints {
+ hasEarthPhoto
+} -setup {
+ .m1 entryconfigure 4 -image {}
+} -body {
+ .m1 entryconfigure 4 -image image1
+ lindex [.m1 entryconfigure 4 -image] 4
+} -cleanup {
+ .m1 entryconfigure 4 -image {}
+} -result {image1}
+
+test menu-2.126 {entry configuration options 5 -image image1 radiobutton} -constraints {
+ hasEarthPhoto
+} -setup {
+ .m1 entryconfigure 5 -image {}
+} -body {
+ .m1 entryconfigure 5 -image image1
+ lindex [.m1 entryconfigure 5 -image] 4
+} -cleanup {
+ .m1 entryconfigure 5 -image {}
+} -result {image1}
+
+test menu-2.127 {entry configuration options 0 -image bogus tearoff} -body {
+ .m1 entryconfigure 0 -image bogus
+} -returnCodes error -result {unknown option "-image"}
+
+test menu-2.128 {entry configuration options 1 -image bogus command} -body {
+ .m1 entryconfigure 1 -image bogus
+} -returnCodes error -result {image "bogus" doesn't exist}
+
+test menu-2.129 {entry configuration options 2 -image bogus cascade} -body {
+ .m1 entryconfigure 2 -image bogus
+} -returnCodes error -result {image "bogus" doesn't exist}
+
+test menu-2.130 {entry configuration options 3 -image bogus separator} -body {
+ .m1 entryconfigure 3 -image bogus
+} -returnCodes error -result {unknown option "-image"}
+
+test menu-2.131 {entry configuration options 4 -image bogus checkbutton} -body {
+ .m1 entryconfigure 4 -image bogus
+} -returnCodes error -result {image "bogus" doesn't exist}
+
+test menu-2.132 {entry configuration options 5 -image bogus radiobutton} -body {
+ .m1 entryconfigure 5 -image bogus
+} -returnCodes error -result {image "bogus" doesn't exist}
+
+test menu-2.133 {entry configuration options 0 -image {} tearoff} -body {
+ .m1 entryconfigure 0 -image
+} -returnCodes error -result {unknown option "-image"}
+
+test menu-2.134 {entry configuration options 1 -image {} command} -setup {
+ .m1 entryconfigure 1 -image {}
+} -body {
+ .m1 entryconfigure 1 -image
+ lindex [.m1 entryconfigure 1 -image] 4
+} -result {}
+
+test menu-2.135 {entry configuration options 2 -image {} cascade} -setup {
+ .m1 entryconfigure 2 -image {}
+} -body {
+ .m1 entryconfigure 2 -image
+ lindex [.m1 entryconfigure 2 -image] 4
+} -result {}
+
+test menu-2.136 {entry configuration options 3 -image {} separator} -body {
+ .m1 entryconfigure 3 -image
+} -returnCodes error -result {unknown option "-image"}
+
+test menu-2.137 {entry configuration options 4 -image {} checkbutton} -body {
+ .m1 entryconfigure 4 -image
+ lindex [.m1 entryconfigure 4 -image] 4
+} -result {}
+
+test menu-2.138 {entry configuration options 5 -image {} radiobutton} -body {
+ .m1 entryconfigure 5 -image
+ lindex [.m1 entryconfigure 5 -image] 4
+} -result {}
+
+test menu-2.139 {entry configuration options 0 -indicatoron 1 tearoff} -body {
+ .m1 entryconfigure 0 -indicatoron 1
+} -returnCodes error -result {unknown option "-indicatoron"}
+
+test menu-2.140 {entry configuration options 1 -indicatoron 1 command} -body {
+ .m1 entryconfigure 1 -indicatoron 1
+} -returnCodes error -result {unknown option "-indicatoron"}
+
+test menu-2.141 {entry configuration options 2 -indicatoron 1 cascade} -body {
+ .m1 entryconfigure 2 -indicatoron 1
+} -returnCodes error -result {unknown option "-indicatoron"}
+
+test menu-2.142 {entry configuration options 3 -indicatoron 1 separator} -body {
+ .m1 entryconfigure 3 -indicatoron 1
+} -returnCodes error -result {unknown option "-indicatoron"}
+
+test menu-2.143 {entry configuration options 4 -indicatoron 1 checkbutton} -body {
+ .m1 entryconfigure 4 -indicatoron 1
+ lindex [.m1 entryconfigure 4 -indicatoron] 4
+} -result {1}
+
+test menu-2.144 {entry configuration options 5 -indicatoron 1 radiobutton} -body {
+ .m1 entryconfigure 5 -indicatoron 1
+ lindex [.m1 entryconfigure 5 -indicatoron] 4
+} -result {1}
+
+test menu-2.145 {entry configuration options 0 -label test tearoff} -body {
+ .m1 entryconfigure 0 -label test
+} -returnCodes error -result {unknown option "-label"}
+
+test menu-2.146 {entry configuration options 1 -label test command} -body {
+ .m1 entryconfigure 1 -label test
+ lindex [.m1 entryconfigure 1 -label] 4
+} -result {test}
+
+test menu-2.147 {entry configuration options 2 -label test cascade} -body {
+ .m1 entryconfigure 2 -label test
+ lindex [.m1 entryconfigure 2 -label] 4
+} -result {test}
+
+test menu-2.148 {entry configuration options 3 -label test separator} -body {
+ .m1 entryconfigure 3 -label test
+} -returnCodes error -result {unknown option "-label"}
+
+test menu-2.149 {entry configuration options 4 -label test checkbutton} -body {
+ .m1 entryconfigure 4 -label test
+ lindex [.m1 entryconfigure 4 -label] 4
+} -result {test}
+
+test menu-2.150 {entry configuration options 5 -label test radiobutton} -body {
+ .m1 entryconfigure 5 -label test
+ lindex [.m1 entryconfigure 5 -label] 4
+} -result {test}
+
+test menu-2.151 {entry configuration options 0 -menu .m2 tearoff} -body {
+ .m1 entryconfigure 0 -menu .m2
+} -returnCodes error -result {unknown option "-menu"}
+
+test menu-2.152 {entry configuration options 1 -menu .m2 command} -body {
+ .m1 entryconfigure 1 -menu .m2
+} -returnCodes error -result {unknown option "-menu"}
+
+test menu-2.153 {entry configuration options 2 -menu .m2 cascade} -body {
+ .m1 entryconfigure 2 -menu .m2
+ lindex [.m1 entryconfigure 2 -menu] 4
+} -result {.m2}
+
+test menu-2.154 {entry configuration options 3 -menu .m2 separator} -body {
+ .m1 entryconfigure 3 -menu .m2
+} -returnCodes error -result {unknown option "-menu"}
+
+test menu-2.155 {entry configuration options 4 -menu .m2 checkbutton} -body {
+ .m1 entryconfigure 4 -menu .m2
+} -returnCodes error -result {unknown option "-menu"}
+
+test menu-2.156 {entry configuration options 5 -menu .m2 radiobutton} -body {
+ .m1 entryconfigure 5 -menu .m2
+} -returnCodes error -result {unknown option "-menu"}
+
+test menu-2.157 {entry configuration options 0 -offvalue off tearoff} -body {
+ .m1 entryconfigure 0 -offvalue off
+} -returnCodes error -result {unknown option "-offvalue"}
+
+test menu-2.158 {entry configuration options 1 -offvalue off command} -body {
+ .m1 entryconfigure 1 -offvalue off
+} -returnCodes error -result {unknown option "-offvalue"}
+
+test menu-2.159 {entry configuration options 2 -offvalue off cascade} -body {
+ .m1 entryconfigure 2 -offvalue off
+} -returnCodes error -result {unknown option "-offvalue"}
+
+test menu-2.160 {entry configuration options 3 -offvalue off separator} -body {
+ .m1 entryconfigure 3 -offvalue off
+} -returnCodes error -result {unknown option "-offvalue"}
+
+test menu-2.161 {entry configuration options 4 -offvalue off checkbutton} -body {
+ .m1 entryconfigure 4 -offvalue off
+ lindex [.m1 entryconfigure 4 -offvalue] 4
+} -result {off}
+
+test menu-2.162 {entry configuration options 5 -offvalue off radiobutton} -body {
+ .m1 entryconfigure 5 -offvalue off
+} -returnCodes error -result {unknown option "-offvalue"}
+
+test menu-2.163 {entry configuration options 0 -onvalue on tearoff} -body {
+ .m1 entryconfigure 0 -onvalue on
+} -returnCodes error -result {unknown option "-onvalue"}
+
+test menu-2.164 {entry configuration options 1 -onvalue on command} -body {
+ .m1 entryconfigure 1 -onvalue on
+} -returnCodes error -result {unknown option "-onvalue"}
+
+test menu-2.165 {entry configuration options 2 -onvalue on cascade} -body {
+ .m1 entryconfigure 2 -onvalue on
+} -returnCodes error -result {unknown option "-onvalue"}
+
+test menu-2.166 {entry configuration options 3 -onvalue on separator} -body {
+ .m1 entryconfigure 3 -onvalue on
+} -returnCodes error -result {unknown option "-onvalue"}
+
+test menu-2.167 {entry configuration options 4 -onvalue on checkbutton} -body {
+ .m1 entryconfigure 4 -onvalue on
+ lindex [.m1 entryconfigure 4 -onvalue] 4
+} -result {on}
+
+test menu-2.168 {entry configuration options 5 -onvalue on radiobutton} -body {
+ .m1 entryconfigure 5 -onvalue on
+} -returnCodes error -result {unknown option "-onvalue"}
+
+test menu-2.169 {entry configuration options 0 -selectcolor #110022 tearoff} -body {
+ .m1 entryconfigure 0 -selectcolor #110022
+} -returnCodes error -result {unknown option "-selectcolor"}
+
+test menu-2.170 {entry configuration options 1 -selectcolor #110022 command} -body {
+ .m1 entryconfigure 1 -selectcolor #110022
+} -returnCodes error -result {unknown option "-selectcolor"}
+
+test menu-2.171 {entry configuration options 2 -selectcolor #110022 cascade} -body {
+ .m1 entryconfigure 2 -selectcolor #110022
+} -returnCodes error -result {unknown option "-selectcolor"}
+
+test menu-2.172 {entry configuration options 3 -selectcolor #110022 separator} -body {
+ .m1 entryconfigure 3 -selectcolor #110022
+} -returnCodes error -result {unknown option "-selectcolor"}
+
+test menu-2.173 {entry configuration options 4 -selectcolor #110022 checkbutton} -body {
+ .m1 entryconfigure 4 -selectcolor #110022
+ lindex [.m1 entryconfigure 4 -selectcolor] 4
+} -result {#110022}
+
+test menu-2.174 {entry configuration options 5 -selectcolor #110022 radiobutton} -body {
+ .m1 entryconfigure 5 -selectcolor #110022
+ lindex [.m1 entryconfigure 5 -selectcolor] 4
+} -result {#110022}
+
+test menu-2.175 {entry configuration options 0 -selectcolor non-existent tearoff} -body {
+ .m1 entryconfigure 0 -selectcolor non-existent
+} -returnCodes error -result {unknown option "-selectcolor"}
+
+test menu-2.176 {entry configuration options 1 -selectcolor non-existent command} -body {
+ .m1 entryconfigure 1 -selectcolor non-existent
+} -returnCodes error -result {unknown option "-selectcolor"}
+
+test menu-2.177 {entry configuration options 2 -selectcolor non-existent cascade} -body {
+ .m1 entryconfigure 2 -selectcolor non-existent
+} -returnCodes error -result {unknown option "-selectcolor"}
+
+test menu-2.178 {entry configuration options 3 -selectcolor non-existent separator} -body {
+ .m1 entryconfigure 3 -selectcolor non-existent
+} -returnCodes error -result {unknown option "-selectcolor"}
+
+test menu-2.179 {entry configuration options 4 -selectcolor non-existent checkbutton} -body {
+ .m1 entryconfigure 4 -selectcolor non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.180 {entry configuration options 5 -selectcolor non-existent radiobutton} -body {
+ .m1 entryconfigure 5 -selectcolor non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+
+test menu-2.181 {entry configuration options 0 -selectimage image1 tearoff} -constraints {
+ hasEarthPhoto
+} -body {
+ .m1 entryconfigure 0 -selectimage image1
+} -returnCodes error -result {unknown option "-selectimage"}
+
+test menu-2.182 {entry configuration options 1 -selectimage image1 command} -constraints {
+ hasEarthPhoto
+} -body {
+ .m1 entryconfigure 1 -selectimage image1
+} -returnCodes error -result {unknown option "-selectimage"}
+
+test menu-2.183 {entry configuration options 2 -selectimage image1 cascade} -constraints {
+ hasEarthPhoto
+} -body {
+ .m1 entryconfigure 2 -selectimage image1
+} -returnCodes error -result {unknown option "-selectimage"}
+
+test menu-2.184 {entry configuration options 3 -selectimage image1 separator} -constraints {
+ hasEarthPhoto
+} -body {
+ .m1 entryconfigure 3 -selectimage image1
+} -returnCodes error -result {unknown option "-selectimage"}
+
+test menu-2.185 {entry configuration options 4 -selectimage image1 checkbutton} -constraints {
+ hasEarthPhoto
+} -setup {
+ .m1 entryconfigure 4 -selectimage {}
+} -body {
+ .m1 entryconfigure 4 -selectimage image1
+ lindex [.m1 entryconfigure 4 -selectimage] 4
+} -cleanup {
+ .m1 entryconfigure 4 -selectimage {}
+} -result {image1}
+
+test menu-2.186 {entry configuration options 5 -selectimage image1 radiobutton} -constraints {
+ hasEarthPhoto
+} -setup {
+ .m1 entryconfigure 5 -selectimage {}
+} -body {
+ .m1 entryconfigure 5 -selectimage image1
+ lindex [.m1 entryconfigure 5 -selectimage] 4
+} -cleanup {
+ .m1 entryconfigure 5 -selectimage {}
+} -result {image1}
+
+test menu-2.187 {entry configuration options 0 -selectimage bogus tearoff} -body {
+ .m1 entryconfigure 0 -selectimage bogus
+} -returnCodes error -result {unknown option "-selectimage"}
+
+test menu-2.188 {entry configuration options 1 -selectimage bogus command} -body {
+ .m1 entryconfigure 1 -selectimage bogus
+} -returnCodes error -result {unknown option "-selectimage"}
+
+test menu-2.189 {entry configuration options 2 -selectimage bogus cascade} -body {
+ .m1 entryconfigure 2 -selectimage bogus
+} -returnCodes error -result {unknown option "-selectimage"}
+
+test menu-2.190 {entry configuration options 3 -selectimage bogus separator} -body {
+ .m1 entryconfigure 3 -selectimage bogus
+} -returnCodes error -result {unknown option "-selectimage"}
+
+test menu-2.191 {entry configuration options 4 -selectimage bogus checkbutton} -body {
+ .m1 entryconfigure 4 -selectimage bogus
+} -returnCodes error -result {image "bogus" doesn't exist}
+
+test menu-2.192 {entry configuration options 5 -selectimage bogus radiobutton} -body {
+ .m1 entryconfigure 5 -selectimage bogus
+} -returnCodes error -result {image "bogus" doesn't exist}
+
+test menu-2.193 {entry configuration options 0 -selectimage {} tearoff} -body {
+ .m1 entryconfigure 0 -selectimage
+} -returnCodes error -result {unknown option "-selectimage"}
+
+test menu-2.194 {entry configuration options 1 -selectimage {} command} -body {
+ .m1 entryconfigure 1 -selectimage
+} -returnCodes error -result {unknown option "-selectimage"}
+
+test menu-2.195 {entry configuration options 2 -selectimage {} cascade} -body {
+ .m1 entryconfigure 2 -selectimage
+} -returnCodes error -result {unknown option "-selectimage"}
+
+test menu-2.196 {entry configuration options 3 -selectimage {} separator} -body {
+ .m1 entryconfigure 3 -selectimage
+} -returnCodes error -result {unknown option "-selectimage"}
+
+test menu-2.197 {entry configuration options 4 -selectimage {} checkbutton} -body {
+ .m1 entryconfigure 4 -selectimage
+ lindex [.m1 entryconfigure 4 -selectimage] 4
+} -result {}
+
+test menu-2.198 {entry configuration options 5 -selectimage {} radiobutton} -body {
+ .m1 entryconfigure 5 -selectimage
+ lindex [.m1 entryconfigure 5 -selectimage] 4
+} -result {}
+
+test menu-2.199 {entry configuration options 0 -state normal tearoff} -body {
+ .m1 entryconfigure 0 -state normal
+ lindex [.m1 entryconfigure 0 -state] 4
+} -result {normal}
+
+test menu-2.200 {entry configuration options 1 -state normal command} -body {
+ .m1 entryconfigure 1 -state normal
+ lindex [.m1 entryconfigure 1 -state] 4
+} -result {normal}
+
+test menu-2.201 {entry configuration options 2 -state normal cascade} -body {
+ .m1 entryconfigure 2 -state normal
+ lindex [.m1 entryconfigure 2 -state] 4
+} -result {normal}
+
+test menu-2.202 {entry configuration options 3 -state normal separator} -body {
+ .m1 entryconfigure 3 -state normal
+} -returnCodes error -result {unknown option "-state"}
+
+test menu-2.203 {entry configuration options 4 -state normal checkbutton} -body {
+ .m1 entryconfigure 4 -state normal
+ lindex [.m1 entryconfigure 4 -state] 4
+} -result {normal}
+
+test menu-2.204 {entry configuration options 5 -state normal radiobutton} -body {
+ .m1 entryconfigure 5 -state normal
+ lindex [.m1 entryconfigure 5 -state] 4
+} -result {normal}
+
+test menu-2.205 {entry configuration options 0 -value {any string} tearoff} -body {
+ .m1 entryconfigure 0 -value {any string}
+} -returnCodes error -result {unknown option "-value"}
+
+test menu-2.206 {entry configuration options 1 -value {any string} command} -body {
+ .m1 entryconfigure 1 -value {any string}
+} -returnCodes error -result {unknown option "-value"}
+
+test menu-2.207 {entry configuration options 2 -value {any string} cascade} -body {
+ .m1 entryconfigure 2 -value {any string}
+} -returnCodes error -result {unknown option "-value"}
+
+test menu-2.208 {entry configuration options 3 -value {any string} separator} -body {
+ .m1 entryconfigure 3 -value {any string}
+} -returnCodes error -result {unknown option "-value"}
+
+test menu-2.209 {entry configuration options 4 -value {any string} checkbutton} -body {
+ .m1 entryconfigure 4 -value {any string}
+} -returnCodes error -result {unknown option "-value"}
+
+test menu-2.210 {entry configuration options 5 -value {any string} radiobutton} -body {
+ .m1 entryconfigure 5 -value {any string}
+ lindex [.m1 entryconfigure 5 -value] 4
+} -result {any string}
+
+test menu-2.211 {entry configuration options 0 -variable {any string} tearoff} -body {
+ .m1 entryconfigure 0 -variable {any string}
+} -returnCodes error -result {unknown option "-variable"}
+
+test menu-2.212 {entry configuration options 1 -variable {any string} command} -body {
+ .m1 entryconfigure 1 -variable {any string}
+} -returnCodes error -result {unknown option "-variable"}
+
+test menu-2.213 {entry configuration options 2 -variable {any string} cascade} -body {
+ .m1 entryconfigure 2 -variable {any string}
+} -returnCodes error -result {unknown option "-variable"}
+
+test menu-2.214 {entry configuration options 3 -variable {any string} separator} -body {
+ .m1 entryconfigure 3 -variable {any string}
+} -returnCodes error -result {unknown option "-variable"}
+
+test menu-2.215 {entry configuration options 4 -variable {any string} checkbutton} -body {
+ .m1 entryconfigure 4 -variable {any string}
+ lindex [.m1 entryconfigure 4 -variable] 4
+} -result {any string}
+
+test menu-2.216 {entry configuration options 5 -variable {any string} radiobutton} -body {
+ .m1 entryconfigure 5 -variable {any string}
+ lindex [.m1 entryconfigure 5 -variable] 4
+} -result {any string}
+
+test menu-2.217 {entry configuration options 0 -underline 0 tearoff} -body {
+ .m1 entryconfigure 0 -underline 0
+} -returnCodes error -result {unknown option "-underline"}
+
+test menu-2.218 {entry configuration options 1 -underline 0 command} -body {
+ .m1 entryconfigure 1 -underline 0
+ lindex [.m1 entryconfigure 1 -underline] 4
+} -result {0}
+
+test menu-2.219 {entry configuration options 2 -underline 0 cascade} -body {
+ .m1 entryconfigure 2 -underline 0
+ lindex [.m1 entryconfigure 2 -underline] 4
+} -result {0}
+
+test menu-2.220 {entry configuration options 3 -underline 0 separator} -body {
+ .m1 entryconfigure 3 -underline 0
+} -returnCodes error -result {unknown option "-underline"}
+
+test menu-2.221 {entry configuration options 4 -underline 0 checkbutton} -body {
+ .m1 entryconfigure 4 -underline 0
+ lindex [.m1 entryconfigure 4 -underline] 4
+} -result {0}
+
+test menu-2.222 {entry configuration options 5 -underline 0 radiobutton} -body {
+ .m1 entryconfigure 5 -underline 0
+ lindex [.m1 entryconfigure 5 -underline] 4
+} -result {0}
+
+test menu-2.223 {entry configuration options 0 -underline 3p tearoff} -body {
+ .m1 entryconfigure 0 -underline 3p
+} -returnCodes error -result {unknown option "-underline"}
+
+test menu-2.224 {entry configuration options 1 -underline 3p command} -body {
+ .m1 entryconfigure 1 -underline 3p
+} -returnCodes error -result {expected integer but got "3p"}
+
+test menu-2.225 {entry configuration options 2 -underline 3p cascade} -body {
+ .m1 entryconfigure 2 -underline 3p
+} -returnCodes error -result {expected integer but got "3p"}
+
+test menu-2.226 {entry configuration options 3 -underline 3p separator} -body {
+ .m1 entryconfigure 3 -underline 3p
+} -returnCodes error -result {unknown option "-underline"}
+
+test menu-2.227 {entry configuration options 4 -underline 3p checkbutton} -body {
+ .m1 entryconfigure 4 -underline 3p
+} -returnCodes error -result {expected integer but got "3p"}
+
+test menu-2.228 {entry configuration options 5 -underline 3p radiobutton} -body {
+ .m1 entryconfigure 5 -underline 3p
+} -returnCodes error -result {expected integer but got "3p"}
+
+deleteWindows
if {[testConstraint hasEarthPhoto]} {
image delete image1
}
-destroy .m1
-destroy .m2
-test menu-3.1 {MenuWidgetCmd procedure} {
- catch {destroy .m1}
+
+
+test menu-3.1 {MenuWidgetCmd procedure} -setup {
+ destroy .m1
+} -body {
menu .m1
- list [catch {.m1} msg] $msg [destroy .m1]
-} {1 {wrong # args: should be ".m1 option ?arg arg ...?"} {}}
-test menu-3.2 {MenuWidgetCmd, Tcl_Preserve and Tcl_Release} {nonUnixUserInteraction } {
- catch {destroy .m1}
+ .m1
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {wrong # args: should be ".m1 option ?arg ...?"}
+test menu-3.2 {MenuWidgetCmd, Tcl_Preserve and Tcl_Release} -constraints {
+ nonUnixUserInteraction
+} -setup {
+ destroy .m1
+} -body {
menu .m1 -postcommand "destroy .m1"
.m1 add command -label "menu-3.2: Hit Escape"
- list [catch {.m1 post 40 40} msg] $msg
-} {0 {}}
-test menu-3.3 {MenuWidgetCmd procedure, "activate" option} {
- catch {destroy .m1}
+ .m1 post 40 40
+} -cleanup {
+ destroy .m1
+} -returnCodes ok -result {}
+test menu-3.3 {MenuWidgetCmd procedure, "activate" option} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "test"
- list [catch {.m1 activate} msg] $msg [destroy .m1]
-} {1 {wrong # args: should be ".m1 activate index"} {}}
-test menu-3.4 {MenuWidgetCmd procedure, "activate" option} {
- catch {destroy .m1}
+ .m1 activate
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {wrong # args: should be ".m1 activate index"}
+test menu-3.4 {MenuWidgetCmd procedure, "activate" option} -setup {
+ destroy .m1
+} -body {
menu .m1
- list [catch {.m1 activate "foo"} msg] $msg [destroy .m1]
-} {1 {bad menu entry index "foo"} {}}
-test menu-3.5 {MenuWidgetCmd procedure, "activate" option} {
- catch {destroy .m1}
+ .m1 activate "foo"
+} -returnCodes error -result {bad menu entry index "foo"}
+test menu-3.5 {MenuWidgetCmd procedure, "activate" option} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "test"
.m1 add separator
- list [catch {.m1 activate 2} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-3.6 {MenuWidgetCmd procedure, "activate" option} {
- catch {destroy .m1}
+ .m1 activate 2
+} -cleanup {
+ destroy .m1
+} -result {}
+test menu-3.6 {MenuWidgetCmd procedure, "activate" option} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "test"
.m1 entryconfigure 1 -state disabled
- list [catch {.m1 activate 1} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-3.7 {MenuWidgetCmd procedure, "activate" option} {
- catch {destroy .m1}
+ .m1 activate 1
+} -cleanup {
+ destroy .m1
+} -result {}
+test menu-3.7 {MenuWidgetCmd procedure, "activate" option} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "test"
- list [catch {.m1 activate 1} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-3.8 {MenuWidgetCmd procedure, "add" option} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 add} msg] $msg [destroy .m1]
-} {1 {wrong # args: should be ".m1 add type ?options?"} {}}
-test menu-3.9 {MenuWidgetCmd procedure, "add" option} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 add foo} msg] $msg [destroy .m1]
-} {1 {bad menu entry type "foo": must be cascade, checkbutton, command, radiobutton, or separator} {}}
-test menu-3.10 {MenuWidgetCmd procedure, "add" option} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 add separator} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-3.11 {MenuWidgetCmd procedure, "cget" option} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 cget} msg] $msg [destroy .m1]
-} {1 {wrong # args: should be ".m1 cget option"} {}}
-test menu-3.12 {MenuWidgetCmd procedure, "cget" option} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 cget -gorp} msg] $msg [destroy .m1]
-} {1 {unknown option "-gorp"} {}}
-test menu-3.13 {MenuWidgetCmd procedure, "cget" option} {
- catch {destroy .m1}
+ .m1 activate 1
+} -cleanup {
+ destroy .m1
+} -result {}
+test menu-3.8 {MenuWidgetCmd procedure, "add" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {wrong # args: should be ".m1 add type ?-option value ...?"}
+test menu-3.9 {MenuWidgetCmd procedure, "add" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add foo
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {bad menu entry type "foo": must be cascade, checkbutton, command, radiobutton, or separator}
+test menu-3.10 {MenuWidgetCmd procedure, "add" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 add separator
+} -cleanup {
+ destroy .m1
+} -result {}
+test menu-3.11 {MenuWidgetCmd procedure, "cget" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 cget
+} -returnCodes error -result {wrong # args: should be ".m1 cget option"}
+test menu-3.12 {MenuWidgetCmd procedure, "cget" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 cget -gorp
+} -returnCodes error -result {unknown option "-gorp"}
+test menu-3.13 {MenuWidgetCmd procedure, "cget" option} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 configure -postcommand "Some string"
- list [catch {.m1 cget -postcommand} msg] $msg [destroy .m1]
-} {0 {Some string} {}}
-test menu-3.14 {MenuWidgetCmd procedure, "clone" option} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 clone} msg] $msg [destroy .m1]
-} {1 {wrong # args: should be ".m1 clone newMenuName ?menuType?"} {}}
-test menu-3.15 {MenuWidgetCmd procedure, "clone" option} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 clone a b c d} msg] $msg [destroy .m1]
-} {1 {wrong # args: should be ".m1 clone newMenuName ?menuType?"} {}}
-test menu-3.16 {MenuWidgetCmd procedure, "clone" option} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 clone .m1.clone1} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-3.17 {MenuWidgetCmd procedure, "clone" option} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 clone .m1.clone1 tearoff} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-3.18 {MenuWidgetCmd procedure, "configure" option} {
- catch {destroy .m1}
- menu .m1
- list [catch {llength [.m1 configure]} msg] $msg [destroy .m1]
-} {0 20 {}}
-test menu-3.19 {MenuWidgetCmd procedure, "configure" option} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 configure -gorp} msg] $msg [destroy .m1]
-} {1 {unknown option "-gorp"} {}}
-test menu-3.20 {MenuWidgetCmd procedure, "configure" option} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 configure -postcommand "A random String"} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-3.21 {MenuWidgetCmd procedure, "configure" option} {
- catch {destroy .m1}
+ .m1 cget -postcommand
+} -cleanup {
+ destroy .m1
+} -result {Some string}
+test menu-3.14 {MenuWidgetCmd procedure, "clone" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 clone
+} -returnCodes error -result {wrong # args: should be ".m1 clone newMenuName ?menuType?"}
+test menu-3.15 {MenuWidgetCmd procedure, "clone" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 clone a b c d
+} -returnCodes error -result {wrong # args: should be ".m1 clone newMenuName ?menuType?"}
+test menu-3.16 {MenuWidgetCmd procedure, "clone" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 clone .m1.clone1
+} -cleanup {
+ destroy .m1
+} -result {}
+test menu-3.17 {MenuWidgetCmd procedure, "clone" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 clone .m1.clone1 tearoff
+} -cleanup {
+ destroy .m1
+} -result {}
+test menu-3.18 {MenuWidgetCmd procedure, "configure" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ llength [.m1 configure]
+} -cleanup {
+ destroy .m1
+} -result {20}
+test menu-3.19 {MenuWidgetCmd procedure, "configure" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 configure -gorp
+} -returnCodes error -result {unknown option "-gorp"}
+test menu-3.20 {MenuWidgetCmd procedure, "configure" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 configure -postcommand "A random String"
+} -cleanup {
+ destroy .m1
+} -result {}
+test menu-3.21 {MenuWidgetCmd procedure, "configure" option} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 configure -postcommand "Another string"
- list [catch {lindex [.m1 configure -postcommand] 4} msg] $msg [destroy .m1]
-} {0 {Another string} {}}
-test menu-3.22 {MenuWidgetCmd procedure, "delete" option} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 delete} msg] $msg [destroy .m1]
-} {1 {wrong # args: should be ".m1 delete first ?last?"} {}}
-test menu-3.23 {MenuWidgetCmd procedure, "delete" option} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 delete foo} msg] $msg [destroy .m1]
-} {1 {bad menu entry index "foo"} {}}
-test menu-3.24 {MenuWidgetCmd procedure, "delete" option} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 delete 0 "foo"} msg] $msg [destroy .m1]
-} {1 {bad menu entry index "foo"} {}}
-test menu-3.25 {MenuWidgetCmd procedure, "delete" option} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 delete 0} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-3.26 {MenuWidgetCmd procedure, "delete" option} {
- catch {destroy .m1}
+ lindex [.m1 configure -postcommand] 4
+} -cleanup {
+ destroy .m1
+} -result {Another string}
+test menu-3.22 {MenuWidgetCmd procedure, "delete" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 delete
+} -returnCodes error -result {wrong # args: should be ".m1 delete first ?last?"}
+test menu-3.23 {MenuWidgetCmd procedure, "delete" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 delete foo
+} -returnCodes error -result {bad menu entry index "foo"}
+test menu-3.24 {MenuWidgetCmd procedure, "delete" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 delete 0 "foo"
+} -returnCodes error -result {bad menu entry index "foo"}
+test menu-3.25 {MenuWidgetCmd procedure, "delete" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 delete 0
+} -cleanup {
+ destroy .m1
+} -result {}
+test menu-3.26 {MenuWidgetCmd procedure, "delete" option} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "foo"
- list [catch {.m1 delete 1 0} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-3.27 {MenuWidgetCmd procedure, "delete" option} {
- catch {destroy .m1}
+ .m1 delete 1 0
+} -cleanup {
+ destroy .m1
+} -result {}
+test menu-3.27 {MenuWidgetCmd procedure, "delete" option} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "1"
.m1 add command -label "2"
.m1 add command -label "3"
- list [catch {.m1 delete 1 3} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-3.28 {MenuWidgetCmd procedure, "delete" option} {
- catch {destroy .m1}
+ .m1 delete 1 3
+} -cleanup {
+ destroy .m1
+} -result {}
+test menu-3.28 {MenuWidgetCmd procedure, "delete" option} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "1"
.m1 add command -label "2"
.m1 add command -label "3"
.m1 activate 2
- list [catch {.m1 delete 1 3} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-3.29 {MenuWidgetCmd procedure, "delete" option} {
- catch {destroy .m1}
+ .m1 delete 1 3
+} -cleanup {
+ destroy .m1
+} -result {}
+test menu-3.29 {MenuWidgetCmd procedure, "delete" option} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "1"
.m1 add command -label "2"
.m1 add command -label "3"
.m1 activate 3
- list [catch {.m1 delete 1} msg] $msg [destroy .m1]
-} {0 {} {}}
+ .m1 delete 1
+} -cleanup {
+ destroy .m1
+} -result {}
test menu-3.29+1 {MenuWidgetCmd, "delete", Bug 220950} -setup {
destroy .m1
} -body {
@@ -690,224 +1464,328 @@ test menu-3.29+1 {MenuWidgetCmd, "delete", Bug 220950} -setup {
} -cleanup {
destroy .m1
} -result ok
-test menu-3.30 {MenuWidgetCmd procedure, "entrycget" option} {
- catch {destroy .m1}
+test menu-3.30 {MenuWidgetCmd procedure, "entrycget" option} -setup {
+ destroy .m1
+} -body {
menu .m1
- list [catch {.m1 entrycget} msg] $msg [destroy .m1]
-} {1 {wrong # args: should be ".m1 entrycget index option"} {}}
-test menu-3.31 {MenuWidgetCmd procedure, "entrycget" option} {
- catch {destroy .m1}
+ .m1 entrycget
+} -returnCodes error -result {wrong # args: should be ".m1 entrycget index option"}
+test menu-3.31 {MenuWidgetCmd procedure, "entrycget" option} -setup {
+ destroy .m1
+} -body {
menu .m1
- list [catch {.m1 entrycget index option foo} msg] $msg [destroy .m1]
-} {1 {wrong # args: should be ".m1 entrycget index option"} {}}
-test menu-3.32 {MenuWidgetCmd procedure, "entrycget" option} {
- catch {destroy .m1}
+ .m1 entrycget index option foo
+} -returnCodes error -result {wrong # args: should be ".m1 entrycget index option"}
+test menu-3.32 {MenuWidgetCmd procedure, "entrycget" option} -setup {
+ destroy .m1
+} -body {
menu .m1
- list [catch {.m1 entrycget foo -label} msg] $msg [destroy .m1]
-} {1 {bad menu entry index "foo"} {}}
-test menu-3.33 {MenuWidgetCmd procedure, "entrycget" option} {
- catch {destroy .m1}
+ .m1 entrycget foo -label
+} -returnCodes error -result {bad menu entry index "foo"}
+test menu-3.33 {MenuWidgetCmd procedure, "entrycget" option} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "test"
- list [catch {.m1 entrycget 1 -label} msg] $msg [destroy .m1]
-} {0 test {}}
-test menu-3.34 {MenuWidgetCmd procedure, "entryconfigure" option} {
- catch {destroy .m1}
+ .m1 entrycget 1 -label
+} -cleanup {
+ destroy .m1
+} -result {test}
+test menu-3.34 {MenuWidgetCmd procedure, "entryconfigure" option} -setup {
+ destroy .m1
+} -body {
menu .m1
- list [catch {.m1 entryconfigure} msg] $msg [destroy .m1]
-} {1 {wrong # args: should be ".m1 entryconfigure index ?option value ...?"} {}}
-test menu-3.35 {MenuWidgetCmd procedure, "entryconfigure" option} {
- catch {destroy .m1}
+ .m1 entryconfigure
+} -returnCodes error -result {wrong # args: should be ".m1 entryconfigure index ?-option value ...?"}
+test menu-3.35 {MenuWidgetCmd procedure, "entryconfigure" option} -setup {
+ destroy .m1
+} -body {
menu .m1
- list [catch {.m1 entryconfigure foo} msg] $msg [destroy .m1]
-} {1 {bad menu entry index "foo"} {}}
-test menu-3.36 {MenuWidgetCmd procedure, "entryconfigure" option} {
- catch {destroy .m1}
+ .m1 entryconfigure foo
+} -returnCodes error -result {bad menu entry index "foo"}
+test menu-3.36 {MenuWidgetCmd procedure, "entryconfigure" option} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "test"
- list [catch {llength [.m1 entryconfigure 1]} msg] $msg [destroy .m1]
-} {0 15 {}}
-test menu-3.37 {MenuWidgetCmd procedure, "entryconfigure" option} {
- catch {destroy .m1}
+ llength [.m1 entryconfigure 1]
+} -cleanup {
+ destroy .m1
+} -result {15}
+test menu-3.37 {MenuWidgetCmd procedure, "entryconfigure" option} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "test"
- list [catch {lindex [.m1 entryconfigure 1 -label] 4} msg] $msg [destroy .m1]
-} {0 test {}}
-test menu-3.38 {MenuWidgetCmd procedure, "entryconfigure" option} {
- catch {destroy .m1}
+ lindex [.m1 entryconfigure 1 -label] 4
+} -cleanup {
+ destroy .m1
+} -result {test}
+test menu-3.38 {MenuWidgetCmd procedure, "entryconfigure" option} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "test"
.m1 entryconfigure 1 -label "changed"
- list [catch {lindex [.m1 entryconfigure 1 -label] 4} msg] $msg [destroy .m1]
-} {0 changed {}}
-test menu-3.39 {MenuWidgetCmd procedure, "index" option} {
- catch {destroy .m1}
+ lindex [.m1 entryconfigure 1 -label] 4
+} -cleanup {
+ destroy .m1
+} -result {changed}
+test menu-3.39 {MenuWidgetCmd procedure, "index" option} -setup {
+ destroy .m1
+} -body {
menu .m1
- list [catch {.m1 index} msg] $msg [destroy .m1]
-} {1 {wrong # args: should be ".m1 index string"} {}}
-test menu-3.40 {MenuWidgetCmd procedure, "index" option} {
- catch {destroy .m1}
+ .m1 index
+} -returnCodes error -result {wrong # args: should be ".m1 index string"}
+test menu-3.40 {MenuWidgetCmd procedure, "index" option} -setup {
+ destroy .m1
+} -body {
menu .m1
- list [catch {.m1 index foo} msg] $msg [destroy .m1]
-} {1 {bad menu entry index "foo"} {}}
-test menu-3.41 {MenuWidgetCmd procedure, "index" option} {
- catch {destroy .m1}
+ .m1 index foo
+} -returnCodes error -result {bad menu entry index "foo"}
+test menu-3.41 {MenuWidgetCmd procedure, "index" option} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "test"
- list [catch {.m1 index "test"} msg] $msg [destroy .m1]
-} {0 1 {}}
-test menu-3.42 {MenuWidgetCmd procedure, "insert" option} {
- catch {destroy .m1}
+ .m1 index "test"
+} -cleanup {
+ destroy .m1
+} -result {1}
+test menu-3.42 {MenuWidgetCmd procedure, "insert" option} -setup {
+ destroy .m1
+} -body {
menu .m1
- list [catch {.m1 insert} msg] $msg [destroy .m1]
-} {1 {wrong # args: should be ".m1 insert index type ?options?"} {}}
-test menu-3.43 {MenuWidgetCmd procedure, "insert" option} {
- catch {destroy .m1}
+ .m1 insert
+} -returnCodes error -result {wrong # args: should be ".m1 insert index type ?-option value ...?"}
+test menu-3.43 {MenuWidgetCmd procedure, "insert" option} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 insert 1 command -label "test"
- list [catch {.m1 entrycget 1 -label} msg] $msg [destroy .m1]
-} {0 test {}}
-test menu-3.44 {MenuWidgetCmd procedure, "invoke" option} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 invoke} msg] $msg [destroy .m1]
-} {1 {wrong # args: should be ".m1 invoke index"} {}}
-test menu-3.45 {MenuWidgetCmd procedure, "invoke" option} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 invoke foo} msg] $msg [destroy .m1]
-} {1 {bad menu entry index "foo"} {}}
-test menu-3.46 {MenuWidgetCmd procedure, "invoke" option} {
- catch {destroy .m1}
+ .m1 entrycget 1 -label
+} -cleanup {
+ destroy .m1
+} -result {test}
+test menu-3.44 {MenuWidgetCmd procedure, "invoke" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 invoke
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {wrong # args: should be ".m1 invoke index"}
+test menu-3.45 {MenuWidgetCmd procedure, "invoke" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 invoke foo
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {bad menu entry index "foo"}
+test menu-3.46 {MenuWidgetCmd procedure, "invoke" option} -setup {
+ destroy .m1
+} -body {
catch {unset foo}
menu .m1
.m1 add command -label "set foo" -command "set foo hello"
- list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1]
-} {0 hello 0 hello 0 {} {}}
-test menu-3.47 {MenuWidgetCmd procedure, "post" option} {
- catch {destroy .m1}
+ list [.m1 invoke 1] [set foo] [unset foo]
+} -cleanup {
+ destroy .m1
+} -returnCodes ok -result {hello hello {}}
+test menu-3.47 {MenuWidgetCmd procedure, "post" option} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "On Windows, hit Escape to get this menu to go away"
- list [catch {.m1 post} msg] $msg [destroy .m1]
-} {1 {wrong # args: should be ".m1 post x y"} {}}
-test menu-3.48 {MenuWidgetCmd procedure, "post" option} {
- catch {destroy .m1}
+ .m1 post
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {wrong # args: should be ".m1 post x y"}
+test menu-3.48 {MenuWidgetCmd procedure, "post" option} -setup {
+ destroy .m1
+} -body {
menu .m1
- list [catch {.m1 post foo 40} msg] $msg [destroy .m1]
-} {1 {expected integer but got "foo"} {}}
-test menu-3.49 {MenuWidgetCmd procedure, "post" option} {
- catch {destroy .m1}
+ .m1 post foo 40
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {expected integer but got "foo"}
+test menu-3.49 {MenuWidgetCmd procedure, "post" option} -setup {
+ destroy .m1
+} -body {
menu .m1
- list [catch {.m1 post 40 bar} msg] $msg [destroy .m1]
-} {1 {expected integer but got "bar"} {}}
-test menu-3.50 {MenuWidgetCmd procedure, "post" option} {nonUnixUserInteraction } {
- catch {destroy .m1}
+ .m1 post 40 bar
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {expected integer but got "bar"}
+test menu-3.50 {MenuWidgetCmd procedure, "post" option} -constraints {
+ nonUnixUserInteraction
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "menu-3.53: hit Escape" -command "puts hello"
- list [catch {.m1 post 40 40} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-3.51 {MenuWidgetCmd procedure, "postcascade" option} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 postcascade} msg] $msg [destroy .m1]
-} {1 {wrong # args: should be ".m1 postcascade index"} {}}
-test menu-3.52 {MenuWidgetCmd procedure, "postcascade" option} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 postcascade foo} msg] $msg [destroy .m1]
-} {1 {bad menu entry index "foo"} {}}
-test menu-3.53 {MenuWidgetCmd procedure, "postcascade" option} {nonUnixUserInteraction } {
- catch {destroy .m1}
- catch {destroy .m2}
+ .m1 post 40 40
+} -cleanup {
+ destroy .m1
+} -result {}
+test menu-3.51 {MenuWidgetCmd procedure, "postcascade" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 postcascade
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {wrong # args: should be ".m1 postcascade index"}
+test menu-3.52 {MenuWidgetCmd procedure, "postcascade" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 postcascade foo
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {bad menu entry index "foo"}
+test menu-3.53 {MenuWidgetCmd procedure, "postcascade" option} -constraints {
+ nonUnixUserInteraction
+} -setup {
+ destroy .m1 .m2
+} -body {
menu .m1
.m1 add command -label "menu-3.56 - hit Escape"
menu .m2
.m1 post 40 40
.m1 add cascade -menu .m2
- list [catch {.m1 postcascade 1} msg] $msg [destroy .m1 .m2]
-} {0 {} {}}
-test menu-3.54 {MenuWidgetCmd procedure, "postcascade" option} {
- catch {destroy .m1}
- catch {destroy .m2}
+ .m1 postcascade 1
+} -cleanup {
+ destroy .m1 .m2
+} -result {}
+test menu-3.54 {MenuWidgetCmd procedure, "postcascade" option} -setup {
+ destroy .m1 .m2
+} -body {
menu .m1
menu .m2
.m1 add cascade -menu .m2 -label "menu-3.57 - hit Escape"
.m1 postcascade 1
- list [catch {.m1 postcascade none} msg] $msg [destroy .m1 .m2]
-} {0 {} {}}
-test menu-3.55 {MenuWidgetCmd procedure, "type" option} {
- catch {destroy .m1}
+ .m1 postcascade none
+} -cleanup {
+ destroy .m1 .m2
+} -result {}
+test menu-3.55 {MenuWidgetCmd procedure, "type" option} -setup {
+ destroy .m1
+} -body {
menu .m1
- list [catch {.m1 type} msg] $msg [destroy .m1]
-} {1 {wrong # args: should be ".m1 type index"} {}}
-test menu-3.56 {MenuWidgetCmd procedure, "type" option} {
- catch {destroy .m1}
+ .m1 type
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {wrong # args: should be ".m1 type index"}
+test menu-3.56 {MenuWidgetCmd procedure, "type" option} -setup {
+ destroy .m1
+} -body {
menu .m1
- list [catch {.m1 type foo} msg] $msg [destroy .m1]
-} {1 {bad menu entry index "foo"} {}}
-test menu-3.57 {MenuWidgetCmd procedure, "type" option} {
- catch {destroy .m1}
+ .m1 type foo
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {bad menu entry index "foo"}
+test menu-3.57 {MenuWidgetCmd procedure, "type" option} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "test"
- list [catch {.m1 type 1} msg] $msg [destroy .m1]
-} {0 command {}}
-test menu-3.58 {MenuWidgetCmd procedure, "type" option} {
- catch {destroy .m1}
+ .m1 type 1
+} -cleanup {
+ destroy .m1
+} -result {command}
+test menu-3.58 {MenuWidgetCmd procedure, "type" option} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add separator
- list [catch {.m1 type 1} msg] $msg [destroy .m1]
-} {0 separator {}}
-test menu-3.59 {MenuWidgetCmd procedure, "type" option} {
- catch {destroy .m1}
+ .m1 type 1
+} -cleanup {
+ destroy .m1
+} -result {separator}
+test menu-3.59 {MenuWidgetCmd procedure, "type" option} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add checkbutton -label "test"
- list [catch {.m1 type 1} msg] $msg [destroy .m1]
-} {0 checkbutton {}}
-test menu-3.60 {MenuWidgetCmd procedure, "type" option} {
- catch {destroy .m1}
+ .m1 type 1
+} -cleanup {
+ destroy .m1
+} -result {checkbutton}
+test menu-3.60 {MenuWidgetCmd procedure, "type" option} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add radiobutton -label "test"
- list [catch {.m1 type 1} msg] $msg [destroy .m1]
-} {0 radiobutton {}}
-test menu-3.61 {MenuWidgetCmd procedure, "type" option} {
- catch {destroy .m1}
+ .m1 type 1
+} -cleanup {
+ destroy .m1
+} -result {radiobutton}
+test menu-3.61 {MenuWidgetCmd procedure, "type" option} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add cascade -label "test"
- list [catch {.m1 type 1} msg] $msg [destroy .m1]
-} {0 cascade {}}
-test menu-3.62 {MenuWidgetCmd procedure, "type" option} {
- catch {destroy .m1}
+ .m1 type 1
+} -cleanup {
+ destroy .m1
+} -result {cascade}
+test menu-3.62 {MenuWidgetCmd procedure, "type" option} -setup {
+ destroy .m1
+} -body {
menu .m1
- list [catch {.m1 type 0} msg] $msg [destroy .m1]
-} {0 tearoff {}}
-test menu-3.63 {MenuWidgetCmd procedure, "unpost" option} {
- catch {destroy .m1}
+ .m1 type 0
+} -cleanup {
+ destroy .m1
+} -result {tearoff}
+test menu-3.63 {MenuWidgetCmd procedure, "unpost" option} -setup {
+ destroy .m1
+} -body {
menu .m1
- list [catch {.m1 unpost foo} msg] $msg [destroy .m1]
-} {1 {wrong # args: should be ".m1 unpost"} {}}
-test menu-3.64 {MenuWidgetCmd procedure, "unpost" option} {nonUnixUserInteraction } {
- catch {destroy .m1}
+ .m1 unpost foo
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {wrong # args: should be ".m1 unpost"}
+test menu-3.64 {MenuWidgetCmd procedure, "unpost" option} -constraints {
+ nonUnixUserInteraction
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "menu-3.68 - hit Escape"
.m1 post 40 40
- list [catch {.m1 unpost} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-3.65 {MenuWidgetCmd procedure, "yposition" option} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 yposition} msg] $msg [destroy .m1]
-} {1 {wrong # args: should be ".m1 yposition index"} {}}
-test menu-3.66 {MenuWidgetCmd procedure, "yposition" option} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 yposition 1}] [destroy .m1]
-} {0 {}}
-test menu-3.67 {MenuWidgetCmd procedure, bad option} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 foo} msg] $msg [destroy .m1]
-} {1 {bad option "foo": must be activate, add, cget, clone, configure, delete, entrycget, entryconfigure, index, insert, invoke, post, postcascade, type, unpost, xposition, or yposition} {}}
-test menu-3.68 {MenuWidgetCmd procedure, fix for bug#508988} {
+ .m1 unpost
+} -cleanup {
+ destroy .m1
+} -result {}
+test menu-3.65 {MenuWidgetCmd procedure, "yposition" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 yposition
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {wrong # args: should be ".m1 yposition index"}
+test menu-3.66 {MenuWidgetCmd procedure, "yposition" option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 yposition 1
+} -cleanup {
+ destroy .m1
+} -result {1}
+test menu-3.67 {MenuWidgetCmd procedure, bad option} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ .m1 foo
+} -cleanup {
+ destroy .m1
+} -returnCodes error -result {bad option "foo": must be activate, add, cget, clone, configure, delete, entrycget, entryconfigure, index, insert, invoke, post, postcascade, type, unpost, xposition, or yposition}
+test menu-3.68 {MenuWidgetCmd procedure, fix for bug#508988} -setup {
+ deleteWindows
+} -body {
set t .t
set m1 .t.m1
set c1 .t.c1
@@ -922,12 +1800,12 @@ test menu-3.68 {MenuWidgetCmd procedure, fix for bug#508988} {
$t configure -menu $m1
$m1 entryconfigure 1 -menu $c2 -label c2
$t configure -menu ""
- set l [list [winfo exists $c1] [winfo exists $c2]]
- destroy $t;
- set l;
-} {1 1}
+ list [winfo exists $c1] [winfo exists $c2]
+} -cleanup {
+ deleteWindows
+} -result {1 1}
test menu-3.69 {MenuWidgetCmd procedure, "xposition" option} -setup {
- catch {destroy .m1}
+ destroy .m1
menu .m1
} -body {
.m1 xposition
@@ -935,7 +1813,7 @@ test menu-3.69 {MenuWidgetCmd procedure, "xposition" option} -setup {
destroy .m1
} -returnCodes error -result {wrong # args: should be ".m1 xposition index"}
test menu-3.70 {MenuWidgetCmd procedure, "xposition" option} -setup {
- catch {destroy .m1}
+ destroy .m1
menu .m1
} -body {
.m1 xposition 1
@@ -944,126 +1822,162 @@ test menu-3.70 {MenuWidgetCmd procedure, "xposition" option} -setup {
destroy .m1
} -result {}
-test menu-4.1 {TkInvokeMenu: disabled} {
- catch {destroy .m1}
+
+test menu-4.1 {TkInvokeMenu: disabled} -setup {
+ destroy .m1
+} -body {
catch {unset foo}
menu .m1
.m1 add checkbutton -label "test" -variable foo -onvalue on -offvalue off \
-state disabled
- list [catch {.m1 invoke 1} msg] [destroy .m1] $foo
-} {0 {} off}
-test menu-4.2 {TkInvokeMenu: tearoff} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 invoke 0} msg] [destroy .m1]
-} {0 {}}
-test menu-4.3 {TkInvokeMenu: checkbutton -on} {
- catch {destroy .m1}
+ list [catch {.m1 invoke 1} msg] $foo
+} -cleanup {
+ destroy .m1
+} -result {0 off}
+test menu-4.2 {TkInvokeMenu: tearoff} -setup {
+ destroy .m1
+} -body {
+ menu .m1
+ catch {.m1 invoke 0}
+} -cleanup {
+ deleteWindows
+} -result {0}
+test menu-4.3 {TkInvokeMenu: checkbutton -on} -setup {
+ destroy .m1
+} -body {
catch {unset foo}
menu .m1
.m1 add checkbutton -label "test" -variable foo -onvalue on -offvalue off
- list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1]
-} {0 {} 0 on 0 {} {}}
-test menu-4.4 {TkInvokeMenu: checkbutton -off} {
- catch {destroy .m1}
+ list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 \
+ [catch {unset foo} msg3] $msg3
+} -cleanup {
+ destroy .m1
+} -result {0 {} 0 on 0 {}}
+test menu-4.4 {TkInvokeMenu: checkbutton -off} -setup {
+ destroy .m1
+} -body {
catch {unset foo}
menu .m1
.m1 add checkbutton -label "test" -variable foo -onvalue on -offvalue off
.m1 invoke 1
- list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1]
-} {0 {} 0 off 0 {} {}}
-test menu-4.5 {TkInvokeMenu: checkbutton array element} {
- catch {destroy .m1}
+ list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3
+} -cleanup {
+ destroy .m1
+} -result {0 {} 0 off 0 {}}
+test menu-4.5 {TkInvokeMenu: checkbutton array element} -setup {
+ destroy .m1
+} -body {
catch {unset foo}
menu .m1
.m1 add checkbutton -label "test" -variable foo(1) -onvalue on
- list [catch {.m1 invoke 1} msg] $msg [catch {set foo(1)} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1]
-} {0 {} 0 on 0 {} {}}
-test menu-4.6 {TkInvokeMenu: radiobutton} {
- catch {destroy .m1}
+ list [catch {.m1 invoke 1} msg] $msg [catch {set foo(1)} msg2] $msg2 [catch {unset foo} msg3] $msg3
+} -cleanup {
+ destroy .m1
+} -result {0 {} 0 on 0 {}}
+test menu-4.6 {TkInvokeMenu: radiobutton} -setup {
+ destroy .m1
+} -body {
catch {unset foo}
menu .m1
.m1 add radiobutton -label "1" -variable foo -value one
.m1 add radiobutton -label "2" -variable foo -value two
.m1 add radiobutton -label "3" -variable foo -value three
- list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1]
-} {0 {} 0 one 0 {} {}}
-test menu-4.7 {TkInvokeMenu: radiobutton} {
- catch {destroy .m1}
+ list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3
+} -cleanup {
+ destroy .m1
+} -result {0 {} 0 one 0 {}}
+test menu-4.7 {TkInvokeMenu: radiobutton} -setup {
+ destroy .m1
+} -body {
catch {unset foo}
menu .m1
.m1 add radiobutton -label "1" -variable foo -value one
.m1 add radiobutton -label "2" -variable foo -value two
.m1 add radiobutton -label "3" -variable foo -value three
- list [catch {.m1 invoke 2} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1]
-} {0 {} 0 two 0 {} {}}
-test menu-4.8 {TkInvokeMenu: radiobutton} {
- catch {destroy .m1}
+ list [catch {.m1 invoke 2} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3
+} -cleanup {
+ destroy .m1
+} -result {0 {} 0 two 0 {}}
+test menu-4.8 {TkInvokeMenu: radiobutton} -setup {
+ destroy .m1
+} -body {
catch {unset foo}
menu .m1
.m1 add radiobutton -label "1" -variable foo -value one
.m1 add radiobutton -label "2" -variable foo -value two
.m1 add radiobutton -label "3" -variable foo -value three
- list [catch {.m1 invoke 3} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1]
-} {0 {} 0 three 0 {} {}}
-test menu-4.9 {TkInvokeMenu: radiobutton array element} {
- catch {destroy .m1}
+ list [catch {.m1 invoke 3} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3
+} -cleanup {
+ destroy .m1
+} -result {0 {} 0 three 0 {}}
+test menu-4.9 {TkInvokeMenu: radiobutton array element} -setup {
+ destroy .m1
+} -body {
catch {unset foo}
menu .m1
.m1 add radiobutton -label "1" -variable foo(2) -value one
.m1 add radiobutton -label "2" -variable foo(2) -value two
.m1 add radiobutton -label "3" -variable foo(2) -value three
- list [catch {.m1 invoke 3} msg] $msg [catch {set foo(2)} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1]
-} {0 {} 0 three 0 {} {}}
-test menu-4.10 {TkInvokeMenu} {
- catch {destroy .m1}
- catch {unset menu_test}
+ list [catch {.m1 invoke 3} msg] $msg [catch {set foo(2)} msg2] $msg2 [catch {unset foo} msg3] $msg3
+} -cleanup {
+ destroy .m1
+} -result {0 {} 0 three 0 {}}
+test menu-4.10 {TkInvokeMenu} -setup {
+ destroy .m1
+} -body {
+ catch {unset foo}
menu .m1
.m1 add command -label "test" -command "set menu_test menu-4.8"
- list [catch {.m1 invoke 1} msg] $msg [catch {set menu_test} msg2] $msg2 [catch {unset menu_test} msg3] $msg3 [destroy .m1]
-} {0 menu-4.8 0 menu-4.8 0 {} {}}
-test menu-4.11 {TkInvokeMenu} {
- catch {destroy .m1}
+ list [catch {.m1 invoke 1} msg] $msg [catch {set menu_test} msg2] $msg2 [catch {unset menu_test} msg3] $msg3
+} -cleanup {
+ destroy .m1
+} -result {0 menu-4.8 0 menu-4.8 0 {}}
+test menu-4.11 {TkInvokeMenu} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add cascade -label "test" -menu .m1.m2
- list [catch {.m1 invoke 1} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-4.12 {TkInvokeMenu} {
- catch {destroy .m1}
+ list [catch {.m1 invoke 1} msg] $msg
+} -cleanup {
+ destroy .m1
+} -result {0 {}}
+test menu-4.12 {TkInvokeMenu} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "test" -command ".m1 delete 1"
- list [catch {.m1 invoke 1} msg] $msg [catch {.m1 type "test"} msg2] $msg2 [destroy .m1]
-} {0 {} 1 {bad menu entry index "test"} {}}
+ list [catch {.m1 invoke 1} msg] $msg [catch {.m1 type "test"} msg2] $msg2
+} -cleanup {
+ destroy .m1
+} -result {0 {} 1 {bad menu entry index "test"}}
-test menu-5.1 {DestroyMenuInstance} {
- catch {destroy .m1}
+test menu-5.1 {DestroyMenuInstance} -setup {
+ destroy .m1
+} -body {
menu .m1
- list [catch {destroy .m1} msg] $msg
-} {0 {}}
-test menu-5.2 {DestroyMenuInstance - cascade menu} {
- catch {destroy .m1}
- catch {destroy .m2}
+ destroy .m1
+} -returnCodes ok
+test menu-5.2 {DestroyMenuInstance - cascade menu} -setup {
+ destroy .m1 .m2
+} -body {
menu .m1
.m1 add cascade -menu .m2
menu .m2
- list [catch {destroy .m2} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-5.3 {DestroyMenuInstance - multiple cascade parents} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .m3}
+ destroy .m1 .m2
+} -returnCodes ok
+test menu-5.3 {DestroyMenuInstance - multiple cascade parents} -setup {
+ destroy .m1 .m2 .m3
+} -body {
menu .m1
.m1 add cascade -menu .m3
menu .m2
.m2 add cascade -menu .m3
menu .m3
- list [catch {destroy .m3} msg] $msg [destroy .m1 .m2]
-} {0 {} {}}
-test menu-5.4 {DestroyMenuInstance - multiple cascade parents} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .m3}
- catch {destroy .m4}
+ list [destroy .m3] [destroy .m1 .m2]
+} -returnCodes ok -result {{} {}}
+test menu-5.4 {DestroyMenuInstance - multiple cascade parents} -setup {
+ destroy .m1 .m2 .m3 .m4
+} -body {
menu .m1
.m1 add cascade -menu .m4
menu .m2
@@ -1071,21 +1985,20 @@ test menu-5.4 {DestroyMenuInstance - multiple cascade parents} {
menu .m3
.m3 add cascade -menu .m4
menu .m4
- list [catch {destroy .m4} msg] $msg [destroy .m1 .m2 .m3]
-} {0 {} {}}
-test menu-5.5 {DestroyMenuInstance - cascades of cloned menus} {
- catch {destroy .m1}
- catch {destroy .m2}
+ list [destroy .m4] [destroy .m1 .m2 .m3]
+} -returnCodes ok -result {{} {}}
+test menu-5.5 {DestroyMenuInstance - cascades of cloned menus} -setup {
+ destroy .m1 .m2
+} -body {
menu .m1
menu .m2
.m1 add cascade -menu .m2
. configure -menu .m1
- list [catch {destroy .m2} msg] $msg [.m1 entrycget 1 -menu] [. configure -menu ""] [destroy .m1]
-} {0 {} .m2 {} {}}
-test menu-5.6 {DestroyMenuInstance - cascades of cloned menus} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .t2}
+ list [destroy .m2] [.m1 entrycget 1 -menu] [. configure -menu ""] [destroy .m1]
+} -returnCodes ok -result {{} .m2 {} {}}
+test menu-5.6 {DestroyMenuInstance - cascades of cloned menus} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add cascade -menu .m2
menu .m2
@@ -1093,190 +2006,190 @@ test menu-5.6 {DestroyMenuInstance - cascades of cloned menus} {
toplevel .t2
wm geometry .t2 +0+0
.t2 configure -menu .m1
- list [catch {destroy .m2} msg] $msg [. configure -menu ""] [destroy .t2 .m1]
-} {0 {} {} {}}
-test menu-5.7 {DestroyMenuInstance - basic clones} {
- catch {destroy .m1}
+ list [destroy .m2] [. configure -menu ""] [destroy .t2 .m1]
+} -returnCodes ok -result {{} {} {}}
+test menu-5.7 {DestroyMenuInstance - basic clones} -setup {
+ destroy .m1
+} -body {
menu .m1
set tearoff [tk::TearOffMenu .m1]
- list [catch {destroy $tearoff} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-5.8 {DestroyMenuInstance - multiple clones} {
- catch {destroy .m1}
+ list [destroy $tearoff] [destroy .m1]
+} -result {{} {}}
+test menu-5.8 {DestroyMenuInstance - multiple clones} -setup {
+ destroy .m1
+} -body {
menu .m1
set tearoff1 [tk::TearOffMenu .m1]
set tearoff2 [tk::TearOffMenu .m1]
- list [catch {destroy $tearoff1} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-5.9 {DestroyMenuInstace - master menu} {
- catch {destroy .m1}
+ list [destroy $tearoff1] [destroy .m1]
+} -returnCodes ok -result {{} {}}
+test menu-5.9 {DestroyMenuInstace - master menu} -setup {
+ destroy .m1
+} -body {
menu .m1
tk::TearOffMenu .m1
- list [catch {destroy .m1} msg] $msg
-} {0 {}}
-test menu-5.10 {DestroyMenuInstance - freeing entries} {
- catch {destroy .m1}
+ destroy .m1
+} -returnCodes ok
+test menu-5.10 {DestroyMenuInstance - freeing entries} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "foo"
- list [catch {destroy .m1} msg] $msg
-} {0 {}}
-test menu-5.11 {DestroyMenuInstace - no entries} {
- catch {destroy .m1}
+ destroy .m1
+} -returnCodes ok
+test menu-5.11 {DestroyMenuInstace - no entries} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 configure -tearoff 0
- list [catch {destroy .m1} msg] $msg
-} {0 {}}
-test menu-5.12 {DestroyMenuInstance - platform data} {
- catch {destroy .m1}
+ destroy .m1
+} -returnCodes ok
+test menu-5.12 {DestroyMenuInstance - platform data} -setup {
+ destroy .m1
+} -body {
menu .m1
- list [catch {destroy .m1} msg] $msg
-} {0 {}}
-test menu-5.13 {DestroyMenuInstance - clones when mismatched tearoffs} {
- catch {destroy .m1}
- catch {destroy .m2}
+ destroy .m1
+} -returnCodes ok
+test menu-5.13 {DestroyMenuInstance - clones when mismatched tearoffs} -setup {
+ destroy .m1 .m2
+} -body {
menu .m1
menu .m2
.m1 add cascade -menu .m2
set tearoff [tk::TearOffMenu .m1 40 40]
list [destroy .m2] [destroy .m1]
-} {{} {}}
+} -result {{} {}}
+
-test menu-6.1 {TkDestroyMenu} {
- catch {destroy .m1}
+test menu-6.1 {TkDestroyMenu} -setup {
+ destroy .m1
+} -body {
menu .m1
- list [catch {destroy .m1} msg] $msg
-} {0 {}}
-test menu-6.2 {TkDestroyMenu - reentrancy} {
- catch {destroy .m1}
- catch {destroy .m2}
+ destroy .m1
+} -returnCodes ok
+test menu-6.2 {TkDestroyMenu - reentrancy} -setup {
+ destroy .m1 .m2
+} -body {
menu .m1
bind .m1 <Destroy> {destroy .m1}
menu .m2
bind .m2 <Destroy> {destroy .m2}
- list [catch {destroy .m1} msg] $msg [destroy .m2]
-} {0 {} {}}
-test menu-6.3 {TkDestroyMenu - reentrancy} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .m3}
+ list [destroy .m1] [destroy .m2]
+} -returnCodes ok -result {{} {}}
+test menu-6.3 {TkDestroyMenu - reentrancy} -setup {
+ destroy .m1 .m2 .m3
+} -body {
menu .m1
bind .m1 <Destroy> {destroy .m2}
.m1 clone .m2
.m1 clone .m3
- list [catch {destroy .m1} msg] $msg [winfo exists .m2]
-} {0 {} 0}
-test menu-6.4 {TkDestroyMenu - reentrancy - clones} {
- catch {destroy .m1}
- catch {destroy .m2}
+ list [destroy .m1] [winfo exists .m2]
+} -returnCodes ok -result {{} 0}
+test menu-6.4 {TkDestroyMenu - reentrancy - clones} -setup {
+ destroy .m1 .m2
+} -body {
menu .m1
.m1 clone .m2
.m1 clone .m1.m3
- list [catch {destroy .m1} msg] $msg
-} {0 {}}
-test menu-6.5 {TkDestroyMenu} {
- catch {destroy .m1}
- catch {destroy .m2}
+ destroy .m1
+} -cleanup {
+ deleteWindows
+} -returnCodes ok
+test menu-6.5 {TkDestroyMenu} -setup {
+ destroy .m1 .m2
+} -body {
menu .m1
.m1 clone .m2
destroy .m1
winfo exists .m2
-} {0}
-test menu-6.6 {TkDestroyMenu} {
- catch {destroy .m1}
- catch {destroy .m2}
+} -result {0}
+test menu-6.6 {TkDestroyMenu} -setup {
+ destroy .m1 .m2
+} -body {
menu .m1
.m1 clone .m2 tearoff
- list [catch {destroy .m1} msg] $msg
-} {0 {}}
-test menu-6.7 {TkDestroyMenu} {
- catch {destroy .m1}
- catch {destroy .m2}
+ destroy .m1
+} -result {}
+test menu-6.7 {TkDestroyMenu} -setup {
+ destroy .m1 .m2
+} -body {
menu .m1
.m1 clone .m2
destroy .m2
- list [catch {destroy .m1} msg] $msg
-} {0 {}}
-test menu-6.8 {TkDestroyMenu} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .m3}
+ destroy .m1
+} -returnCodes ok -result {}
+test menu-6.8 {TkDestroyMenu} -setup {
+ destroy .m1 .m2 .m3
+} -body {
menu .m1
.m1 clone .m2
.m1 clone .m3
destroy .m1
list [winfo exists .m2] [winfo exists .m3]
-} {0 0}
-test menu-6.9 {TkDestroyMenu} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .m3}
+} -result {0 0}
+test menu-6.9 {TkDestroyMenu} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 clone .m2
.m1 clone .m3
- list [catch {destroy .m2} msg] $msg [catch {destroy .m3} msg2] $msg2 [catch {destroy .m1} msg3] $msg3
-} {0 {} 0 {} 0 {}}
-test menu-6.10 {TkDestroyMenu} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .m3}
+ list [destroy .m2] [destroy .m3] [destroy .m1]
+} -returnCodes ok -result {{} {} {}}
+test menu-6.10 {TkDestroyMenu} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 clone .m2
.m1 clone .m3
- list [catch {destroy .m3} msg] $msg [catch {destroy .m1} msg2] $msg2
-} {0 {} 0 {}}
-test menu-6.11 {TkDestroyMenu} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .m3}
- catch {destroy .m4}
+ list [destroy .m3] [destroy .m1]
+} -returnCodes ok -result {{} {}}
+test menu-6.11 {TkDestroyMenu} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 clone .m2
.m1 clone .m3
.m1 clone .m4
- list [catch {destroy .m2} msg1] $msg1 [catch {destroy .m1} msg2] $msg2
-} {0 {} 0 {}}
-test menu-6.12 {TkDestroyMenu} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .m3}
- catch {destroy .m4}
+ list [destroy .m2] [destroy .m1]
+} -returnCodes ok -result {{} {}}
+test menu-6.12 {TkDestroyMenu} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 clone .m2
.m1 clone .m3
.m1 clone .m4
- list [catch {destroy .m3} msg1] $msg1 [catch {destroy .m1} msg2] $msg2
-} {0 {} 0 {}}
-test menu-6.13 {TkDestroyMenu} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .m3}
- catch {destroy .m4}
+ list [destroy .m3] [destroy .m1]
+} -returnCodes ok -result {{} {}}
+test menu-6.13 {TkDestroyMenu} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 clone .m2
.m1 clone .m3
.m1 clone .m4
- list [catch {destroy .m4} msg1] $msg1 [catch {destroy .m1} msg2] $msg2
-} {0 {} 0 {}}
-test menu-6.14 {TkDestroyMenu} {
- catch {destroy .m1}
+ list [destroy .m4] [destroy .m1]
+} -returnCodes ok -result {{} {}}
+test menu-6.14 {TkDestroyMenu} -setup {
+ destroy .m1
+} -body {
menu .m1
. configure -menu .m1
- list [catch {destroy .m1} msg] $msg [. configure -menu ""]
-} {0 {} {}}
-test menu-6.15 {TkDestroyMenu} {
- catch {destroy .m1}
- catch {destroy .t2}
+ list [destroy .m1] [. configure -menu ""]
+} -returnCodes ok -result {{} {}}
+test menu-6.15 {TkDestroyMenu} -setup {
+ deleteWindows
+} -body {
menu .m1
toplevel .t2
wm geometry .t2 +0+0
. configure -menu .m1
.t2 configure -menu .m1
- list [catch {destroy .m1} msg] $msg [destroy .t2] [. configure -menu ""]
-} {0 {} {} {}}
-test menu-6.16 {TkDestroyMenu} {
- catch {destroy .m1}
- catch {destroy .t2}
- catch {destroy .t3}
+ list [destroy .m1] [destroy .t2] [. configure -menu ""]
+} -result {{} {} {}}
+test menu-6.16 {TkDestroyMenu} -setup {
+ deleteWindows
+} -body {
menu .m1
toplevel .t2
wm geometry .t2 +0+0
@@ -1285,298 +2198,367 @@ test menu-6.16 {TkDestroyMenu} {
. configure -menu .m1
.t2 configure -menu .m1
.t3 configure -menu .m1
- list [catch {destroy .m1} msg] $msg [destroy .t2] [destroy .t3] [. configure -menu ""]
-} {0 {} {} {} {}}
+ list [destroy .m1] [destroy .t2] [destroy .t3] [. configure -menu ""]
+} -result {{} {} {} {}}
-test menu-7.1 {UnhookCascadeEntry} {
- catch {destroy .m1}
+test menu-7.1 {UnhookCascadeEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "test"
- list [catch {destroy .m1} msg] $msg
-} {0 {}}
-test menu-7.2 {UnhookCascadeEntry} {
- catch {destroy .m1}
+ destroy .m1
+} -returnCodes ok
+test menu-7.2 {UnhookCascadeEntry} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add cascade -menu .m2
- list [catch {destroy .m1} msg] $msg
-} {0 {}}
-test menu-7.3 {UnhookCascadeEntry} {
- catch {destroy .m1}
- catch {destroy .m2}
+ destroy .m1
+} -returnCodes ok
+test menu-7.3 {UnhookCascadeEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
menu .m2
.m2 add cascade -menu .cascade
.m1 add cascade -menu .cascade
- list [catch {destroy .m1} msg] $msg [destroy .m2]
-} {0 {} {}}
-test menu-7.4 {UnhookCascadeEntry} {
- catch {destroy .m1}
- catch {destroy .m2}
+ list [destroy .m1] [destroy .m2]
+} -returnCodes ok -result {{} {}}
+test menu-7.4 {UnhookCascadeEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
menu .m2
.m1 add cascade -menu .cascade
.m2 add cascade -menu .cascade
- list [catch {destroy .m1} msg] $msg [destroy .m2]
-} {0 {} {}}
-test menu-7.5 {UnhookCascadeEntry} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .m3}
+ list [destroy .m1] [destroy .m2]
+} -returnCodes ok -result {{} {}}
+test menu-7.5 {UnhookCascadeEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
menu .m2
menu .m3
.m1 add cascade -menu .cascade
.m2 add cascade -menu .cascade
.m3 add cascade -menu .cascade
- list [catch {destroy .m1} msg] $msg [destroy .m2 .m3]
-} {0 {} {}}
-test menu-7.6 {UnhookCascadeEntry} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .m3}
+ list [destroy .m1] [destroy .m2 .m3]
+} -returnCodes ok -result {{} {}}
+test menu-7.6 {UnhookCascadeEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
menu .m2
menu .m3
.m1 add cascade -menu .cascade
.m2 add cascade -menu .cascade
.m3 add cascade -menu .cascade
- list [catch {destroy .m2} msg] $msg [destroy .m1 .m3]
-} {0 {} {}}
-test menu-7.7 {UnhookCascadeEntry} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .m3}
+ list [destroy .m2] [destroy .m1 .m3]
+} -returnCodes ok -result {{} {}}
+test menu-7.7 {UnhookCascadeEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
menu .m2
menu .m3
.m1 add cascade -menu .cascade
.m2 add cascade -menu .cascade
.m3 add cascade -menu .cascade
- list [catch {destroy .m3} msg] $msg [destroy .m1 .m2]
-} {0 {} {}}
-test menu-7.8 {UnhookCascadeEntry} {
- catch {destroy .m1}
- catch {destroy .m2}
+ list [destroy .m3] [destroy .m1 .m2]
+} -returnCodes ok -result {{} {}}
+test menu-7.8 {UnhookCascadeEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
menu .m2
.m1 add cascade -menu .m2
- list [catch {destroy .m1} msg] $msg [destroy .m2]
-} {0 {} {}}
-test menu-7.9 {UnhookCascadeEntry} {
- catch {destroy .m1}
- catch {destroy .m2}
+ list [destroy .m1] [destroy .m2]
+} -returnCodes ok -result {{} {}}
+test menu-7.9 {UnhookCascadeEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
menu .m2
.m1 add cascade -menu .m2
destroy .m1
- list [catch {destroy .m2} msg] $msg
-} {0 {}}
+ destroy .m2
+} -returnCodes ok
-test menu-8.1 {DestroyMenuEntry} {
- catch {destroy .m1}
- catch {destroy .m2}
+test menu-8.1 {DestroyMenuEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
menu .m2
.m1 add cascade -menu .m2
- list [catch {.m1 delete 1} msg] $msg [destroy .m1 .m2]
-} {0 {} {}}
-test menu-8.2 {DestroyMenuEntry} hasEarthPhoto {
+ list [.m1 delete 1] [destroy .m1 .m2]
+} -result {{} {}}
+test menu-8.2 {DestroyMenuEntry} -constraints hasEarthPhoto -setup {
+ deleteWindows
catch {image delete image1a}
- catch {destroy .m1}
+} -body {
image create photo image1a -file $earthPhotoFile
menu .m1
.m1 add command -image image1a
- list [catch {.m1 delete 1} msg] $msg [destroy .m1] [image delete image1a]
-} {0 {} {} {}}
-test menu-8.3 {DestroyMenuEntry} testImageType {
- catch {eval image delete [image names]}
- catch {destroy .m1}
+ list [.m1 delete 1] [destroy .m1] [image delete image1a]
+} -result {{} {} {}}
+test menu-8.3 {DestroyMenuEntry} -constraints testImageType -setup {
+ deleteWindows
+ imageCleanup
+} -body {
image create test image1
image create test image2
menu .m1
.m1 add checkbutton -image image1 -selectimage image2
.m1 invoke 1
- list [catch {.m1 delete 1} msg] $msg [destroy .m1] [eval image delete [image names]]
-} {0 {} {} {}}
-test menu-8.4 {DestroyMenuEntry} {
- catch {destroy .m1}
+ list [.m1 delete 1] [destroy .m1]
+} -cleanup {
+ imageCleanup
+ deleteWindows
+} -result {{} {}}
+test menu-8.4 {DestroyMenuEntry} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add checkbutton -variable foo
- list [catch {.m1 delete 1} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-8.5 {DestroyMenuEntry} {
- catch {destroy .m1}
+ list [.m1 delete 1] [destroy .m1]
+} -result {{} {}}
+test menu-8.5 {DestroyMenuEntry} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "test"
- list [catch {.m1 delete 1} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-8.6 {DestroyMenuEntry} {
- catch {destroy .m1}
+ list [.m1 delete 1] [destroy .m1]
+} -result {{} {}}
+test menu-8.6 {DestroyMenuEntry} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "one"
.m1 add command -label "two"
- list [catch {.m1 delete 1} msg] $msg [.m1 entrycget 1 -label] [destroy .m1]
-} {0 {} two {}}
-test menu-8.7 {DestroyMenuEntry} {
- catch {destroy .m1}
- catch {destroy .m2}
+ list [.m1 delete 1] [.m1 entrycget 1 -label] [destroy .m1]
+} -result {{} two {}}
+test menu-8.7 {DestroyMenuEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "one"
.m1 clone .m2 tearoff
- list [catch {.m2 delete 0} msg] $msg [destroy .m1]
-} {0 {} {}}
+ list [.m2 delete 1] [destroy .m1]
+} -result {{} {}}
+
# test menu-9 - Can only change when fonts change on system, which cannot
# be done from tcl.
-
-test menu-9.1 {ConfigureMenu} {
- catch {destroy .m1}
+test menu-9.1 {ConfigureMenu} -setup {
+ destroy .m1
+} -body {
menu .m1
- list [catch {.m1 configure -postcommand "beep"} msg] $msg [.m1 cget -postcommand] [destroy .m1]
-} {0 {} beep {}}
-test menu-9.2 {ConfigureMenu} {
- catch {destroy .m1}
+ list [.m1 configure -postcommand "beep"] [.m1 cget -postcommand]
+} -cleanup {
+ deleteWindows
+} -result {{} beep}
+test menu-9.2 {ConfigureMenu} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "test"
- list [catch {.m1 configure -tearoff 0} msg] $msg [.m1 entrycget 1 -label] [destroy .m1]
-} {0 {} test {}}
-test menu-9.3 {ConfigureMenu} {
- catch {destroy .m1}
+ list [.m1 configure -tearoff 0] [.m1 entrycget 1 -label]
+} -cleanup {
+ deleteWindows
+} -result {{} test}
+test menu-9.3 {ConfigureMenu} -setup {
+ destroy .m1
+} -body {
menu .m1
- list [catch {.m1 configure -postcommand "beep"} msg] $msg [.m1 cget -postcommand] [destroy .m1]
-} {0 {} beep {}}
-test menu-9.4 {ConfigureMenu} {
- catch {destroy .m1}
+ list [.m1 configure -postcommand "beep"] [.m1 cget -postcommand]
+} -cleanup {
+ deleteWindows
+} -result {{} beep}
+test menu-9.4 {ConfigureMenu} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "test"
- list [catch {.m1 configure -fg red} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-9.5 {ConfigureMenu} {
- catch {destroy .m1}
+ .m1 configure -fg red
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-9.5 {ConfigureMenu} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "test"
.m1 add command -label "two"
- list [catch {.m1 configure -fg red} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-9.6 {ConfigureMenu} {
- catch {destroy .m1}
+ .m1 configure -fg red
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-9.6 {ConfigureMenu} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "test"
.m1 add command -label "two"
.m1 add command -label "three"
- list [catch {.m1 configure -fg red} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-9.7 {ConfigureMenu} {
- catch {destroy .m1}
- catch {destroy .m2}
+ .m1 configure -fg red
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-9.7 {ConfigureMenu} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 clone .m2 tearoff
- list [catch {.m1 configure -fg red} msg] $msg [.m2 cget -fg] [destroy .m1]
-} {0 {} red {}}
-test menu-9.8 {ConfigureMenu} {
- catch {destroy .m1}
- catch {destroy .m2}
+ list [.m1 configure -fg red] [.m2 cget -fg]
+} -cleanup {
+ deleteWindows
+} -result {{} red}
+test menu-9.8 {ConfigureMenu} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 clone .m2 tearoff
- list [catch {.m2 configure -fg red} msg] $msg [.m1 cget -fg] [destroy .m1]
-} {0 {} red {}}
-test menu-9.9 {ConfigureMenu} {
- catch {destroy .m1}
+ list [.m2 configure -fg red] [.m1 cget -fg]
+} -cleanup {
+ deleteWindows
+} -result {{} red}
+test menu-9.9 {ConfigureMenu} -setup {
+ destroy .m1
+} -body {
menu .m1
- list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
+ list [. configure -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+
-test menu-10.1 {PostProcessEntry: array variable} {
- catch {destroy .m1}
+test menu-10.1 {PostProcessEntry: array variable} -setup {
+ destroy .m1
+} -body {
catch {unset foo}
menu .m1
set foo(1) on
.m1 add checkbutton -variable foo(1) -onvalue on -offvalue off -label "Nonsense"
- list [catch {set foo(1)} msg] $msg [destroy .m1]
-} {0 on {}}
-test menu-10.2 {PostProcessEntry: array variable} {
- catch {destroy .m1}
+ set foo(1)
+} -cleanup {
+ deleteWindows
+} -result {on}
+test menu-10.2 {PostProcessEntry: array variable} -setup {
+ destroy .m1
+} -body {
catch {unset foo}
menu .m1
.m1 add checkbutton -variable foo(1) -onvalue on -offvalue off -label "Nonsense"
- list [catch {set foo(1)} msg] $msg [destroy .m1]
-} {0 off {}}
+ set foo(1)
+} -cleanup {
+ deleteWindows
+} -result {off}
-test menu-11.1 {ConfigureMenuEntry} {
- catch {destroy .m1}
+
+test menu-11.1 {ConfigureMenuEntry} -setup {
+ destroy .m1
+} -body {
catch {unset foo}
menu .m1
.m1 add checkbutton -variable foo -onvalue on -offvalue off -label "Nonsense"
- list [catch {.m1 entryconfigure 1 -variable bar} msg] $msg [.m1 entrycget 1 -variable] [destroy .m1]
-} {0 {} bar {}}
-test menu-11.2 {ConfigureMenuEntry} {
- catch {destroy .m1}
+ list [.m1 entryconfigure 1 -variable bar] [.m1 entrycget 1 -variable]
+} -cleanup {
+ deleteWindows
+} -result {{} bar}
+test menu-11.2 {ConfigureMenuEntry} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "test"
- list [catch {.m1 entryconfigure 1 -label ""} msg] $msg [.m1 entrycget 1 -label] [destroy .m1]
-} {0 {} {} {}}
-test menu-11.3 {ConfigureMenuEntry} {
- catch {destroy .m1}
+ list [.m1 entryconfigure 1 -label ""] [.m1 entrycget 1 -label]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-11.3 {ConfigureMenuEntry} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command
- list [catch {.m1 entryconfigure 1 -label "test"} cmd] $cmd [.m1 entrycget 1 -label] [destroy .m1]
-} {0 {} test {}}
-test menu-11.4 {ConfigureMenuEntry} {
- catch {destroy .m1}
+ list [.m1 entryconfigure 1 -label "test"] [.m1 entrycget 1 -label]
+} -cleanup {
+ deleteWindows
+} -result {{} test}
+test menu-11.4 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command
- list [catch {.m1 entryconfigure 1 -accel "S"} msg] $msg [.m1 entrycget 1 -accel] [destroy .m1]
-} {0 {} S {}}
-test menu-11.5 {ConfigureMenuEntry} {
- catch {destroy .m1}
+ list [.m1 entryconfigure 1 -accel "S"] [.m1 entrycget 1 -accel]
+} -cleanup {
+ deleteWindows
+} -result {{} S}
+test menu-11.5 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command
- list [catch {.m1 entryconfigure 1 -label "test"} msg] $msg [.m1 entrycget 1 -label] [destroy .m1]
-} {0 {} test {}}
-test menu-11.6 {ConfigureMenuEntry} {
- catch {destroy .m1}
+ list [.m1 entryconfigure 1 -label "test"] [.m1 entrycget 1 -label]
+} -cleanup {
+ deleteWindows
+} -result {{} test}
+test menu-11.6 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command
- list [catch {.m1 entryconfigure 1 -label "test"} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-11.7 {ConfigureMenuEntry} {
- catch {destroy .m1}
- catch {destroy .m2}
+ .m1 entryconfigure 1 -label "test"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-11.7 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
menu .m2
menu .m1
.m1 add cascade
- list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1 .m2]
-} {0 {} {}}
-test menu-11.8 {ConfigureMenuEntry} {
- catch {destroy .m1}
+ .m1 entryconfigure 1 -label "test" -menu .m2
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-11.8 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add cascade
- list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-11.9 {ConfigureMenuEntry} {
- catch {destroy .m1}
+ .m1 entryconfigure 1 -label "test" -menu .m2
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-11.9 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add cascade -menu .m3
- list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-11.10 {ConfigureMenuEntry} {
- catch {destroy .m1}
+ .m1 entryconfigure 1 -label "test" -menu .m2
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-11.10 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add cascade
- list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-11.11 {ConfigureMenuEntry} {
- catch {destroy .m1}
+ .m1 entryconfigure 1 -label "test" -menu .m2
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-11.11 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add cascade -menu .m2
- list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-11.12 {ConfigureMenuEntry} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .m3}
- catch {destroy .m4}
- catch {destroy .m5}
+ .m1 entryconfigure 1 -label "test" -menu .m2
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-11.12 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
menu .m2
.m2 add cascade -menu .m1
@@ -1586,13 +2568,13 @@ test menu-11.12 {ConfigureMenuEntry} {
.m4 add cascade -menu .m1
menu .m5
.m5 add cascade
- list [catch {.m5 entryconfigure 1 -label "test" -menu .m1} msg] $msg [destroy .m1 .m2 .m3 .m4 .m5]
-} {0 {} {}}
-test menu-11.13 {ConfigureMenuEntry} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .m3}
- catch {destroy .m4}
+ .m5 entryconfigure 1 -label "test" -menu .m1
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-11.13 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
menu .m2
.m2 add cascade -menu .m1
@@ -1600,360 +2582,489 @@ test menu-11.13 {ConfigureMenuEntry} {
.m3 add cascade -menu .m1
menu .m4
.m4 add cascade -menu .m1
- list [catch {.m3 entryconfigure 1 -label "test" -menu .m1} msg] $msg [destroy .m1 .m2 .m3 .m4]
-} {0 {} {}}
-test menu-11.14 {ConfigureMenuEntry} {
- catch {destroy .m1}
+ .m3 entryconfigure 1 -label "test" -menu .m1
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-11.14 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add checkbutton
- list [catch {.m1 entryconfigure 1 -variable "test"} msg] $msg [.m1 entrycget 1 -variable] [destroy .m1]
-} {0 {} test {}}
-test menu-11.15 {ConfigureMenuEntry} {
- catch {destroy .m1}
+ list [.m1 entryconfigure 1 -variable "test"] [.m1 entrycget 1 -variable]
+} -cleanup {
+ deleteWindows
+} -result {{} test}
+test menu-11.15 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
- list [catch {.m1 add checkbutton -label "test"} msg] $msg [.m1 entrycget 1 -variable] [destroy .m1]
-} {0 {} test {}}
-test menu-11.16 {ConfigureMenuEntry} {
- catch {destroy .m1}
+ list [.m1 add checkbutton -label "test"] [.m1 entrycget 1 -variable]
+} -cleanup {
+ deleteWindows
+} -result {{} test}
+test menu-11.16 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
- list [catch {.m1 add radiobutton -label "test"} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-11.17 {ConfigureMenuEntry} {
- catch {destroy .m1}
+ .m1 add radiobutton -label "test"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-11.17 {ConfigureMenuEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add checkbutton
- list [catch {.m1 entryconfigure 1 -onvalue "test"} msg] $msg [.m1 entrycget 1 -onvalue] [destroy .m1]
-} {0 {} test {}}
-test menu-11.18 {ConfigureMenuEntry} testImageType {
- catch {destroy .m1}
- catch {image delete image1}
+ list [.m1 entryconfigure 1 -onvalue "test"] [.m1 entrycget 1 -onvalue]
+} -cleanup {
+ deleteWindows
+} -result {{} test}
+test menu-11.18 {ConfigureMenuEntry} -constraints testImageType -setup {
+ deleteWindows
+ imageCleanup
+} -body {
menu .m1
.m1 add command
image create test image1
- list [catch {.m1 entryconfigure 1 -image image1} msg] $msg [destroy .m1] [image delete image1]
-} {0 {} {} {}}
-test menu-11.19 {ConfigureMenuEntry} {testImageType hasEarthPhoto} {
- catch {destroy .m1}
- catch {image delete image1}
- catch {image delete image2}
+ .m1 entryconfigure 1 -image image1
+} -cleanup {
+ deleteWindows
+ imageCleanup
+} -result {}
+test menu-11.19 {ConfigureMenuEntry} -constraints {
+ testImageType hasEarthPhoto
+} -setup {
+ deleteWindows
+ imageCleanup
+} -body {
image create test image1
image create photo image2 -file $earthPhotoFile
menu .m1
.m1 add command -image image1
- list [catch {.m1 entryconfigure 1 -image image2} msg] $msg [destroy .m1] [image delete image1] [image delete image2]
-} {0 {} {} {} {}}
-test menu-11.20 {ConfigureMenuEntry} {testImageType hasEarthPhoto} {
- catch {destroy .m1}
- catch {image delete image1}
- catch {image delete image2}
+ .m1 entryconfigure 1 -image image2
+} -cleanup {
+ deleteWindows
+ imageCleanup
+} -result {}
+test menu-11.20 {ConfigureMenuEntry} -constraints {
+ testImageType hasEarthPhoto
+} -setup {
+ deleteWindows
+ imageCleanup
+} -body {
image create photo image1 -file $earthPhotoFile
image create test image2
menu .m1
.m1 add checkbutton -image image1
- list [catch {.m1 entryconfigure 1 -selectimage image2} msg] $msg [destroy .m1] [image delete image1] [image delete image2]
-} {0 {} {} {} {}}
-test menu-11.21 {ConfigureMenuEntry} {testImageType hasEarthPhoto} {
- catch {destroy .m1}
- catch {image delete image1}
- catch {image delete image2}
- catch {image delete image3}
+ .m1 entryconfigure 1 -selectimage image2
+} -cleanup {
+ deleteWindows
+ imageCleanup
+} -result {}
+test menu-11.21 {ConfigureMenuEntry} -constraints {
+ testImageType hasEarthPhoto
+} -setup {
+ deleteWindows
+ imageCleanup
+} -body {
image create photo image1 -file $earthPhotoFile
image create test image2
image create test image3
menu .m1
.m1 add checkbutton -image image1 -selectimage image2
- list [catch {.m1 entryconfigure 1 -selectimage image3} msg] $msg [destroy .m1] [image delete image1] [image delete image2] [image delete image3]
-} {0 {} {} {} {} {}}
+ .m1 entryconfigure 1 -selectimage image3
+} -cleanup {
+ deleteWindows
+ imageCleanup
+} -result {}
-test menu-12.1 {ConfigureMenuCloneEntries} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .m3}
+
+test menu-12.1 {ConfigureMenuCloneEntries} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 clone .m2
.m2 configure -tearoff 0
.m1 clone .m3
.m1 add command -label "test"
.m1 add command -label "test2"
- list [list [catch {.m1 entryconfigure 1 -gork "foo"} msg] $msg] [destroy .m1]
-} {{1 {unknown option "-gork"}} {}}
-test menu-12.2 {ConfigureMenuCloneEntries} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .m3}
- catch {destroy .m4}
+ .m1 entryconfigure 1 -gork "foo"
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {unknown option "-gork"}
+test menu-12.2 {ConfigureMenuCloneEntries} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 clone .m2
menu .m3
.m1 add cascade -menu .m3
menu .m4
- list [catch {.m1 entryconfigure 1 -menu .m4} msg] $msg [destroy .m1] [destroy .m3] [destroy .m4]
-} {0 {} {} {} {}}
-test menu-12.3 {ConfigureMenuCloneEntries} {
- catch {destroy .m1}
- catch {destroy .m2}
+ .m1 entryconfigure 1 -menu .m4
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-12.3 {ConfigureMenuCloneEntries} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 clone .m2
.m1 add cascade -label dummy
- list [catch {.m1 entryconfigure dummy -menu .m3} msg] $msg [destroy .m1]
-} {0 {} {}}
-
-test menu-12.4 {ConfigureMenuCloneEntries} {
- catch {destroy .m1}
- catch {destroy .m2}
+ .m1 entryconfigure dummy -menu .m3
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-12.4 {ConfigureMenuCloneEntries} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add cascade -label File -menu .m1.foo
menu .m1.foo
.m1.foo add command -label bar
.m1 clone .m2
- list [catch {.m1 entryconfigure File -state disabled} msg1] $msg1 [destroy .m1]
-} {0 {} {}}
+ .m1 entryconfigure File -state disabled
+} -cleanup {
+ deleteWindows
+} -result {}
-test menu-13.1 {TkGetMenuIndex} {
- catch {destroy .m1}
+
+test menu-13.1 {TkGetMenuIndex} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "active"
.m1 add command -label "test2"
.m1 add command -label "test3"
.m1 activate 2
- list [catch {.m1 entrycget active -label} msg] $msg [destroy .m1]
-} {0 test2 {}}
-test menu-13.2 {TkGetMenuIndex} {
- catch {destroy .m1}
+ .m1 entrycget active -label
+} -cleanup {
+ deleteWindows
+} -result {test2}
+test menu-13.2 {TkGetMenuIndex} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "last"
.m1 add command -label "test2"
.m1 add command -label "test3"
.m1 activate 2
- list [catch {.m1 entrycget last -label} msg] $msg [destroy .m1]
-} {0 test3 {}}
-test menu-13.3 {TkGetMenuIndex} {
- catch {destroy .m1}
+ .m1 entrycget last -label
+} -cleanup {
+ deleteWindows
+} -result {test3}
+test menu-13.3 {TkGetMenuIndex} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "last"
.m1 add command -label "test2"
.m1 add command -label "test3"
.m1 activate 2
- list [catch {.m1 entrycget end -label} msg] $msg [destroy .m1]
-} {0 test3 {}}
-test menu-13.4 {TkGetMenuIndex} {
- catch {destroy .m1}
+ .m1 entrycget end -label
+} -cleanup {
+ deleteWindows
+} -result {test3}
+test menu-13.4 {TkGetMenuIndex} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "test"
- list [catch {.m1 insert last command -label "test2"} msg] $msg [.m1 entrycget last -label] [destroy .m1]
-} {0 {} test2 {}}
-test menu-13.5 {TkGetMenuIndex} {
- catch {destroy .m1}
+ list [.m1 insert last command -label "test2"] [.m1 entrycget last -label]
+} -cleanup {
+ deleteWindows
+} -result {{} test2}
+test menu-13.5 {TkGetMenuIndex} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "test"
- list [catch {.m1 insert end command -label "test2"} msg] $msg [.m1 entrycget end -label] [destroy .m1]
-} {0 {} test2 {}}
-test menu-13.6 {TkGetMenuIndex} {
- catch {destroy .m1}
+ list [.m1 insert end command -label "test2"] [.m1 entrycget end -label]
+} -cleanup {
+ deleteWindows
+} -result {{} test2}
+test menu-13.6 {TkGetMenuIndex} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "active"
.m1 add command -label "test2"
.m1 add command -label "test3"
.m1 activate 2
- list [catch {.m1 entrycget none -label} msg] $msg [destroy .m1]
-} {0 {} {}}
+ .m1 entrycget none -label
+} -cleanup {
+ deleteWindows
+} -result {}
#test menu-13.7 - Need to add @test here.
-test menu-13.7 {TkGetMenuIndex} {
- catch {destroy .m1}
+test menu-13.7 {TkGetMenuIndex} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "active"
.m1 add command -label "test2"
.m1 add command -label "test3"
- list [catch {.m1 entrycget 1 -label} msg] $msg [destroy .m1]
-} {0 active {}}
-test menu-13.8 {TkGetMenuIndex} {
- catch {destroy .m1}
+ .m1 entrycget 1 -label
+} -cleanup {
+ deleteWindows
+} -result {active}
+test menu-13.8 {TkGetMenuIndex} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "active"
- list [catch {.m1 entrycget -1 -label} msg] $msg [destroy .m1]
-} {1 {bad menu entry index "-1"} {}}
-test menu-13.9 {TkGetMenuIndex} {
- catch {destroy .m1}
+ .m1 entrycget -1 -label
+} -returnCodes error -result {bad menu entry index "-1"}
+test menu-13.9 {TkGetMenuIndex} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "test"
.m1 add command -label "test2"
- list [catch {.m1 entrycget 999 -label} msg] $msg [destroy .m1]
-} {0 test2 {}}
-test menu-13.10 {TkGetMenuIndex} {
- catch {destroy .m1}
+ .m1 entrycget 999 -label
+} -cleanup {
+ deleteWindows
+} -result {test2}
+test menu-13.10 {TkGetMenuIndex} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 insert 999 command -label "test"
- list [catch {.m1 entrycget 1 -label} msg] $msg [destroy .m1]
-} {0 test {}}
-test menu-13.11 {TkGetMenuIndex} {
- catch {destroy .m1}
+ .m1 entrycget 1 -label
+} -cleanup {
+ deleteWindows
+} -result {test}
+test menu-13.11 {TkGetMenuIndex} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "1test"
- list [catch {.m1 entrycget 1test -label} msg] $msg [destroy .m1]
-} {0 1test {}}
-test menu-13.12 {TkGetMenuIndex} {
- catch {destroy .m1}
+ .m1 entrycget 1test -label
+} -cleanup {
+ deleteWindows
+} -result {1test}
+test menu-13.12 {TkGetMenuIndex} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "test"
.m1 add command -label "test2" -command "beep"
.m1 add command -label "test3"
- list [catch {.m1 entrycget test2 -command} msg] $msg [destroy .m1]
-} {0 beep {}}
+ .m1 entrycget test2 -command
+} -cleanup {
+ deleteWindows
+} -result {beep}
-test menu-14.1 {MenuCmdDeletedProc} {
- catch {destroy .m1}
+test menu-14.1 {MenuCmdDeletedProc} -setup {
+ deleteWindows
+} -body {
menu .m1
- list [catch {destroy .m1} msg] $msg
-} {0 {}}
-test menu-14.2 {MenuCmdDeletedProc} {
- catch {destroy .m1}
+ destroy .m1
+} -cleanup {
+ deleteWindows
+} -returnCodes ok
+test menu-14.2 {MenuCmdDeletedProc} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 clone .m2
- list [catch {destroy .m1} msg] $msg
-} {0 {}}
+ destroy .m1
+} -cleanup {
+ deleteWindows
+} -returnCodes ok
-test menu-15.1 {MenuNewEntry} {
- catch {destroy .m1}
+test menu-15.1 {MenuNewEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
- list [catch {.m1 add command -label "test"} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-15.2 {MenuNewEntry} {
- catch {destroy .m1}
+ .m1 add command -label "test"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-15.2 {MenuNewEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "test"
.m1 add command -label "test3"
- list [catch {.m1 insert 2 command -label "test2"} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-15.3 {MenuNewEntry} {
- catch {destroy .m1}
+ .m1 insert 2 command -label "test2"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-15.3 {MenuNewEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "test"
- list [catch {.m1 add command -label "test2"} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-15.4 {MenuNewEntry} {
- catch {destroy .m1}
+ .m1 add command -label "test2"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-15.4 {MenuNewEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
- list [catch {.m1 add command -label "test"} msg] $msg [destroy .m1]
-} {0 {} {}}
+ .m1 add command -label "test"
+} -cleanup {
+ deleteWindows
+} -result {}
-test menu-16.1 {MenuAddOrInsert} {
- catch {destroy .m1}
+test menu-16.1 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
menu .m1
- list [catch {.m1 insert foo command -label "test"} msg] $msg [destroy .m1]
-} {1 {bad menu entry index "foo"} {}}
-test menu-16.2 {MenuAddOrInsert} {
- catch {destroy .m1}
+ .m1 insert foo command -label "test"
+} -returnCodes error -result {bad menu entry index "foo"}
+test menu-16.2 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "test"
- list [catch {.m1 insert test command -label "foo"} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-16.3 {MenuAddOrInsert} {
- catch {destroy .m1}
+ .m1 insert test command -label "foo"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-16.3 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
menu .m1
- list [catch {.m1 insert -1 command -label "test"} msg] $msg [destroy .m1]
-} {1 {bad menu entry index "-1"} {}}
-test menu-16.4 {MenuAddOrInsert} {
- catch {destroy .m1}
+ .m1 insert -1 command -label "test"
+} -returnCodes error -result {bad menu entry index "-1"}
+test menu-16.4 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "test"
.m1 insert 0 command -label "test2"
- list [catch {.m1 entrycget 1 -label} msg] $msg [destroy .m1]
-} {0 test2 {}}
-test menu-16.5 {MenuAddOrInsert} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 add cascade} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-16.6 {MenuAddOrInsert} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 add checkbutton} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-16.7 {MenuAddOrInsert} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 add command} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-16.8 {MenuAddOrInsert} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 add radiobutton} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-16.9 {MenuAddOrInsert} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 add separator} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-16.10 {MenuAddOrInsert} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 add blork} msg] $msg [destroy .m1]
-} {1 {bad menu entry type "blork": must be cascade, checkbutton, command, radiobutton, or separator} {}}
-test menu-16.11 {MenuAddOrInsert} {
- catch {destroy .m1}
- menu .m1
- list [catch {.m1 add command} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-16.12 {MenuAddOrInsert} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .m3}
+ .m1 entrycget 1 -label
+} -cleanup {
+ deleteWindows
+} -result {test2}
+test menu-16.5 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add cascade
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-16.6 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add checkbutton
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-16.7 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-16.8 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add radiobutton
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-16.9 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add separator
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-16.10 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add blork
+} -returnCodes error -result {bad menu entry type "blork": must be cascade, checkbutton, command, radiobutton, or separator}
+test menu-16.11 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-16.12 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 clone .m2
.m2 clone .m3
- list [catch {.m2 add command -label "test"} msg1] $msg1 [catch {.m1 entrycget 1 -label} msg2] $msg2 [catch {.m3 entrycget 1 -label} msg3] $msg3 [destroy .m1]
-} {0 {} 0 test 0 test {}}
-test menu-16.13 {MenuAddOrInsert} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .m3}
+ list [.m2 add command -label "test"] [.m1 entrycget 1 -label] [.m3 entrycget 1 -label]
+} -cleanup {
+ deleteWindows
+} -result {{} test test}
+test menu-16.13 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 clone .m2
.m2 clone .m3
- list [catch {.m3 add command -label "test"} msg1] $msg1 [catch {.m1 entrycget 1 -label} msg2] $msg2 [catch {.m2 entrycget 1 -label} msg3] $msg3 [destroy .m1]
-} {0 {} 0 test 0 test {}}
-test menu-16.14 {MenuAddOrInsert} {
- catch {destroy .m1}
+ list [.m3 add command -label "test"] [.m1 entrycget 1 -label] [.m2 entrycget 1 -label]
+} -cleanup {
+ deleteWindows
+} -result {{} test test}
+test menu-16.14 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
menu .m1
- list [catch {.m1 add command -blork} msg] $msg [destroy .m1]
-} {1 {unknown option "-blork"} {}}
-test menu-16.15 {MenuAddOrInsert} {
- catch {destroy .m1}
- catch {destroy .container}
+ .m1 add command -blork
+} -returnCodes error -result {unknown option "-blork"}
+test menu-16.15 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "File"
menu .container
. configure -menu .container
- list [catch {.container add cascade -label "File" -menu .m1} msg] $msg [. configure -menu ""] [destroy .container .m1]
-} {0 {} {} {}}
-test menu-16.16 {MenuAddOrInsert} {
- catch {destroy .m1}
- catch {destroy .m2}
+ list [.container add cascade -label "File" -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-16.16 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
menu .m1
menu .m2
set tearoff [tk::TearOffMenu .m2]
- list [catch {.m2 add cascade -menu .m1} msg] $msg [$tearoff unpost] [catch {destroy .m1} msg2] $msg2 [catch {destroy .m2} msg3] $msg3
-} {0 {} {} 0 {} 0 {}}
-test menu-16.17 {MenuAddOrInsert} {
- catch {destroy .m1}
- catch {destroy .container}
+ list [.m2 add cascade -menu .m1] [$tearoff unpost]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-16.17 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
menu .m1
menu .container
. configure -menu .container
set tearoff [tk::TearOffMenu .container]
- list [catch {.container add cascade -label "File" -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1 .container]
-} {0 {} {} {}}
-test menu-16.18 {MenuAddOrInsert} {
- catch {destroy .m1}
- catch {destroy .container}
+ list [.container add cascade -label "File" -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-16.18 {MenuAddOrInsert} -setup {
+ deleteWindows
+} -body {
menu .m1
menu .container
.container add cascade -menu .m1
. configure -menu .container
- list [catch {.container add cascade -label "File" -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1 .container]
-} {0 {} {} {}}
-test menu-16.19 {MenuAddOrInsert - Insert a cascade deep into the tree} {
- catch {destroy .menubar}
+ list [.container add cascade -label "File" -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-16.19 {MenuAddOrInsert - Insert a cascade deep into the tree} -setup {
+ deleteWindows
+} -body {
menu .menubar
menu .menubar.test -tearoff 0
.menubar add cascade -label Test -underline 0 -menu .menubar.test
@@ -1961,198 +3072,270 @@ test menu-16.19 {MenuAddOrInsert - Insert a cascade deep into the tree} {
.menubar.test.cascade add command -label SubItem -command "puts SubItemSelected"
. configure -menu .menubar
list [catch {.menubar.test add cascade -label SubMenu \
- -menu .menubar.test.cascade} msg] \
- [info commands .\#menubar.\#menubar\#test.\#menubar\#test\#cascade] \
- [. configure -menu ""] [destroy .menubar]
-} {0 .#menubar.#menubar#test.#menubar#test#cascade {} {}}
+ -menu .menubar.test.cascade}] \
+ [info commands .\#menubar.\#menubar\#test.\#menubar\#test\#cascade] \
+ [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {0 .#menubar.#menubar#test.#menubar#test#cascade {}}
-test menu-17.1 {MenuVarProc} {
- catch {destroy .m1}
+
+test menu-17.1 {MenuVarProc} -setup {
+ deleteWindows
+} -body {
catch {unset foo}
menu .m1
set foo "hello"
- list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [catch {unset foo} msg2] $msg2 [destroy .m1]
-} {0 {} 0 {} {}}
+ list [.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye] \
+ [unset foo]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
# menu-17.2 - Don't know how to generate the flags in the if
-test menu-17.2 {MenuVarProc} {
- catch {destroy .m1}
+test menu-17.2 {MenuVarProc} -setup {
+ deleteWindows
+} -body {
catch {unset foo}
menu .m1
- list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [set foo ""] [destroy .m1]
-} {0 {} {} {}}
-test menu-17.3 {MenuVarProc} {
- catch {destroy .m1}
+ list [.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye] \
+ [set foo ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-17.3 {MenuVarProc} -setup {
+ deleteWindows
+} -body {
catch {unset foo}
menu .m1
set foo "hello"
- list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [set foo "hello"] [destroy .m1] [catch {unset foo} msg2] $msg2
-} {0 {} hello {} 0 {}}
-test menu-17.4 {MenuVarProc} {
- catch {destroy .m1}
+ list [.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye] \
+ [set foo "hello"] [unset foo]
+} -cleanup {
+ deleteWindows
+} -result {{} hello {}}
+test menu-17.4 {MenuVarProc} -setup {
+ deleteWindows
+} -body {
menu .m1
set foo "goodbye"
- list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [set foo "hello"] [destroy .m1] [catch {unset foo} msg2] $msg2
-} {0 {} hello {} 0 {}}
-test menu-17.5 {MenuVarProc} {
- catch {destroy .m1}
+ list [.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye] \
+ [set foo "hello"] [unset foo]
+} -cleanup {
+ deleteWindows
+} -result {{} hello {}}
+test menu-17.5 {MenuVarProc} -setup {
+ deleteWindows
+} -body {
menu .m1
set foo "hello"
- list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [set foo "goodbye"] [destroy .m1] [catch {unset foo} msg2] $msg2
-} {0 {} goodbye {} 0 {}}
+ list [.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye] \
+ [set foo "goodbye"] [unset foo]
+} -cleanup {
+ deleteWindows
+} -result {{} goodbye {}}
+
-test menu-18.1 {TkActivateMenuEntry} {
- catch {destroy .m1}
+test menu-18.1 {TkActivateMenuEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "test"
- list [catch {.m1 activate 1} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-18.2 {TkActivateMenuEntry} {
- catch {destroy .m1}
+ .m1 activate 1
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-18.2 {TkActivateMenuEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "test"
- list [catch {.m1 activate 0} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-18.3 {TkActivateMenuEntry} {
- catch {destroy .m1}
+ .m1 activate 0
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-18.3 {TkActivateMenuEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "test"
.m1 add command -label "test2"
.m1 activate 1
- list [catch {.m1 activate 2} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-18.4 {TkActivateMenuEntry} {
- catch {destroy .m1}
+ .m1 activate 2
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-18.4 {TkActivateMenuEntry} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "test"
.m1 add command -label "test2"
.m1 activate 1
- list [catch {.m1 activate 1} msg] $msg [destroy .m1]
-} {0 {} {}}
+ .m1 activate 1
+} -cleanup {
+ deleteWindows
+} -result {}
-test menu-19.1 {TkPostCommand} {nonUnixUserInteraction } {
- catch {destroy .m1}
+
+test menu-19.1 {TkPostCommand} -constraints nonUnixUserInteraction -setup {
+ deleteWindows
+} -body {
menu .m1 -postcommand "set menu_test menu-19.1"
.m1 add command -label "menu-19.1 - hit Escape"
- list [catch {.m1 post 40 40} msg] $msg [.m1 unpost] [set menu_test] [destroy .m1]
-} {0 menu-19.1 {} menu-19.1 {}}
-test menu-19.2 {TkPostCommand} {nonUnixUserInteraction } {
- catch {destroy .m1}
+ list [.m1 post 40 40] [.m1 unpost] [set menu_test]
+} -cleanup {
+ deleteWindows
+} -result {menu-19.1 {} menu-19.1}
+test menu-19.2 {TkPostCommand} -constraints nonUnixUserInteraction -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "menu-19.2 - hit Escape"
- list [catch {.m1 post 40 40} msg] $msg [.m1 unpost] [destroy .m1]
-} {0 {} {} {}}
-
-test menu-20.1 {CloneMenu} {
- catch {destroy .m1}
- catch {destroy .m2}
- menu .m1
- list [catch {.m1 clone .m2} msg1] $msg1 [destroy .m1]
-} {0 {} {}}
-test menu-20.2 {CloneMenu} {
- catch {destroy .m1}
- catch {destroy .m2}
- menu .m1
- list [catch {.m1 clone .m2 normal} msg1] $msg1 [destroy .m1]
-} {0 {} {}}
-test menu-20.3 {CloneMenu} {
- catch {destroy .m1}
- catch {destroy .m2}
- menu .m1
- list [catch {.m1 clone .m2 tearoff} msg1] $msg1 [destroy .m1]
-} {0 {} {}}
-test menu-20.4 {CloneMenu} {
- catch {destroy .m1}
- catch {destroy .m2}
- menu .m1
- list [catch {.m1 clone .m2 menubar} msg1] $msg1 [destroy .m1]
-} {0 {} {}}
-test menu-20.5 {CloneMenu} {
- catch {destroy .m1}
- catch {destroy .m2}
- menu .m1
- list [catch {.m1 clone .m2 foo} msg1] $msg1 [destroy .m1]
-} {1 {bad menu type "foo": must be normal, tearoff, or menubar} {}}
-test menu-20.6 {CloneMenu - hooking up bookeeping ptrs} {
- catch {destroy .m1}
- catch {destroy .m2}
- menu .m1
- list [catch {.m1 clone .m2} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-20.7 {CloneMenu - hooking up bookeeping ptrs - multiple children} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .m3}
+ list [.m1 post 40 40] [.m1 unpost]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+
+test menu-20.1 {CloneMenu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 clone .m2]
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-20.2 {CloneMenu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 clone .m2 normal
+ deleteWindows
+} -result {}
+test menu-20.3 {CloneMenu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 clone .m2 tearoff
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-20.4 {CloneMenu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 clone .m2 menubar
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-20.5 {CloneMenu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 clone .m2 foo
+} -returnCodes error -result {bad menu type "foo": must be normal, tearoff, or menubar}
+test menu-20.6 {CloneMenu - hooking up bookeeping ptrs} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 clone .m2
- list [catch {.m1 clone .m3} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-20.8 {CloneMenu - cascade entries} {
- catch {destroy .m1}
- catch {destroy .foo}
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-20.7 {CloneMenu - hooking up bookeeping ptrs - multiple children} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 clone .m2
+ .m1 clone .m3
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-20.8 {CloneMenu - cascade entries} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add cascade -menu .m2
- list [catch {.m1 clone .foo} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-20.9 {CloneMenu - cascades entries} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .foo}
+ .m1 clone .foo
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-20.9 {CloneMenu - cascades entries} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add cascade -menu .m2
menu .m2
- list [catch {.m1 clone .foo} msg] $msg [destroy .m1 .m2]
-} {0 {} {}}
-test menu-20.10 {CloneMenu - tearoff fields} {
- catch {destroy .m1}
- catch {destroy .m2}
- menu .m1
- list [catch {.m1 clone .m2 normal} msg1] $msg1 [catch {.m2 cget -tearoff} msg2] $msg2 [destroy .m1]
-} {0 {} 0 1 {}}
-test menu-20.11 {CloneMenu} {
- catch {destroy .m1}
- catch {destroy .m2}
+ .m1 clone .foo
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-20.10 {CloneMenu - tearoff fields} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ list [.m1 clone .m2 normal] [.m2 cget -tearoff]
+} -cleanup {
+ deleteWindows
+} -result {{} 1}
+test menu-20.11 {CloneMenu} -setup {
+ deleteWindows
+} -body {
menu .m1
menu .m2
- list [catch {.m1 clone .m2} msg] $msg [destroy .m1 .m2]
-} {1 {window name "m2" already exists in parent} {}}
+ .m1 clone .m2
+} -returnCodes error -result {window name "m2" already exists in parent}
-test menu-21.1 {MenuDoYPosition} {
- catch {destroy .m1}
+test menu-21.1 {MenuDoYPosition} -setup {
+ deleteWindows
+} -body {
menu .m1
- list [catch {.m1 yposition glorp} msg] $msg [destroy .m1]
-} {1 {bad menu entry index "glorp"} {}}
-test menu-21.2 {MenuDoYPosition} {
- catch {destroy .m1}
+ .m1 yposition glorp
+} -returnCodes error -result {bad menu entry index "glorp"}
+test menu-21.2 {MenuDoYPosition} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "Test"
- list [catch {.m1 yposition 1}] [destroy .m1]
-} {0 {}}
+ .m1 yposition 1
+} -cleanup {
+ deleteWindows
+} -returnCodes ok -match glob -result {*}
-test menu-22.1 {GetIndexFromCoords} {
- catch {destroy .m1}
+test menu-22.1 {GetIndexFromCoords} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "test"
.m1 configure -tearoff 0
- list [catch {.m1 index @5} msg] $msg [destroy .m1]
-} {0 0 {}}
-test menu-22.2 {GetIndexFromCoords} {
- catch {destroy .m1}
+ .m1 index @5
+} -cleanup {
+ deleteWindows
+} -result {0}
+test menu-22.2 {GetIndexFromCoords} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "test"
.m1 configure -tearoff 0
- list [catch {.m1 index @5,5} msg] $msg [destroy .m1]
-} {0 0 {}}
-test menu-22.3 {GetIndexFromCoords: mapped window, y only} unix {
- catch {destroy .m1}
+ .m1 index @5,5
+} -cleanup {
+ deleteWindows
+} -result {0}
+test menu-22.3 {GetIndexFromCoords: mapped window, y only} -setup {
+ deleteWindows
+} -constraints {unix} -body {
menu .m1
.m1 add command -label "test"
.m1 configure -tearoff 0
tk_popup .m1 0 0
tkwait visibility .m1
- list [catch {.m1 index @5} msg] $msg [destroy .m1]
-} {0 0 {}}
-test menu-22.4 {GetIndexFromCoords: mapped window x,y} unix {
- catch {destroy .m1}
+ .m1 index @5
+} -cleanup {
+ deleteWindows
+} -result {0}
+test menu-22.4 {GetIndexFromCoords: mapped window x,y} -setup {
+ deleteWindows
+} -constraints {unix} -body {
menu .m1
.m1 add command -label "test"
.m1 configure -tearoff 0
@@ -2160,10 +3343,13 @@ test menu-22.4 {GetIndexFromCoords: mapped window x,y} unix {
tkwait visibility .m1
update
set x [expr {[winfo width .m1] - [.m1 cget -borderwidth] - 1}]
- list [catch {.m1 index @$x,5} msg] $msg [destroy .m1]
-} {0 0 {}}
-test menu-22.5 {GetIndexFromCoords: mapped wide window} unix {
- catch {destroy .m1}
+ .m1 index @$x,5
+} -cleanup {
+ deleteWindows
+} -result {0}
+test menu-22.5 {GetIndexFromCoords: mapped wide window} -setup {
+ deleteWindows
+} -constraints {unix} -body {
menu .m1
.m1 add command -label "test"
.m1 configure -tearoff 0
@@ -2172,105 +3358,137 @@ test menu-22.5 {GetIndexFromCoords: mapped wide window} unix {
wm geometry .m1 200x100
update
set x [expr {[winfo width .m1] - [.m1 cget -borderwidth] - 1}]
- list [catch {.m1 index @$x,5} msg] $msg [destroy .m1]
-} {0 0 {}}
+ .m1 index @$x,5
+} -cleanup {
+ deleteWindows
+} -result {0}
-test menu-23.1 {RecursivelyDeleteMenu} {
- catch {destroy .m1}
+test menu-23.1 {RecursivelyDeleteMenu} -setup {
+ deleteWindows
+} -body {
menu .m1
. configure -menu .m1
- list [catch {. configure -menu ""} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-23.2 {RecursivelyDeleteMenu} {
- catch {destroy .m1}
- catch {destroy .m2}
+ . configure -menu ""
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-23.2 {RecursivelyDeleteMenu} -setup {
+ deleteWindows
+} -body {
menu .m2
.m2 add command -label "test2"
menu .m1
.m1 add cascade -label "test1" -menu .m2
. configure -menu .m1
- list [catch {. configure -menu ""} msg] $msg [destroy .m1 .m2]
-} {0 {} {}}
+ . configure -menu ""
+} -cleanup {
+ deleteWindows
+} -result {}
-test menu-24.1 {TkNewMenuName} {
- catch {destroy .m1}
+test menu-24.1 {TkNewMenuName} -setup {
+ deleteWindows
+} -body {
menu .m1
- list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test menu-24.2 {TkNewMenuName} {
- catch {destroy .m1}
- catch {destroy .m1\#0}
+ list [. configure -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-24.2 {TkNewMenuName} -setup {
+ deleteWindows
+} -body {
menu .m1
menu .m1\#0
- list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test menu-24.3 {TkNewMenuName} {
- catch {destroy .#m}
+ list [. configure -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-24.3 {TkNewMenuName} -setup {
+ deleteWindows
+} -body {
menu .#m
rename .#m hideme
- list [catch {. configure -menu [menu .m]} $msg] [. configure -menu ""] [destroy .#m] [destroy .m] [destroy hideme]
-} {0 {} {} {} {}}
+ list [catch {. configure -menu [menu .m]}] [. configure -menu ""] [destroy .#m] \
+ [destroy .m] [destroy hideme]
+} -result {0 {} {} {} {}}
-test menu-25.1 {TkSetWindowMenuBar} {
+
+test menu-25.1 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
. configure -menu ""
- list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""]
-} {0 {} {}}
-test menu-25.2 {TkSetWindowMenuBar} {
+ list [. configure -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.2 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
. configure -menu ""
- list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""]
-} {0 {} {}}
-test menu-25.3 {TkSetWindowMenuBar} {
+ list [. configure -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.3 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
. configure -menu ""
- catch {destroy .m1}
+ destroy .m1
menu .m1
- list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test menu-25.4 {TkSetWindowMenuBar} {
- catch {destroy .m1}
- catch {destroy .m2}
+ list [. configure -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.4 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
. configure -menu ""
menu .m1
. configure -menu .m1
menu .m2
- list [catch {. configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .m1 .m2]
-} {0 {} {} {}}
-test menu-25.5 {TkSetWindowMenuBar} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .m3}
+ list [. configure -menu .m2] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.5 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
. configure -menu ""
menu .m1
. configure -menu .m1
.m1 clone .m2
menu .m3
- list [catch {. configure -menu .m3} msg] $msg [. configure -menu ""] [destroy .m1 .m3]
-} {0 {} {} {}}
-test menu-25.6 {TkSetWindowMenuBar} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .m3}
+ list [. configure -menu .m3] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.6 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
. configure -menu ""
menu .m1
.m1 clone .m2
. configure -menu .m2
menu .m3
- list [catch {. configure -menu .m3} msg] $msg [. configure -menu ""] [destroy .m1 .m3]
-} {0 {} {} {}}
-test menu-25.7 {TkSetWindowMenuBar} {
- catch {destroy .m1}
- catch {destroy .m2}
+ list [. configure -menu .m3] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.7 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
. configure -menu ""
menu .m1
menu .m2
. configure -menu .m1
toplevel .t2
.t2 configure -menu .m1
- list [catch {.t2 configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .m1 .m2]
-} {0 {} {} {}}
-test menu-25.8 {TkSetWindowMenuBar} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .t2}
+ list [.t2 configure -menu .m2] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.8 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
. configure -menu ""
menu .m1
menu .m2
@@ -2278,13 +3496,13 @@ test menu-25.8 {TkSetWindowMenuBar} {
toplevel .t2
wm geometry .t2 +0+0
.t2 configure -menu .m1
- list [catch {. configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .m1 .m2]
-} {0 {} {} {}}
-test menu-25.9 {TkSetWindowMenuBar} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .t2}
- catch {destroy .t3}
+ list [. configure -menu .m2] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.9 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
. configure -menu ""
menu .m1
menu .m2
@@ -2293,13 +3511,13 @@ test menu-25.9 {TkSetWindowMenuBar} {
wm geometry .t2 +0+0
toplevel .t3 -menu .m1
wm geometry .t3 +0+0
- list [catch {.t3 configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .t3 .m1 .m2]
-} {0 {} {} {}}
-test menu-25.10 {TkSetWindowMenuBar} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .t2}
- catch {destroy .t3}
+ list [.t3 configure -menu .m2] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.10 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
. configure -menu ""
menu .m1
menu .m2
@@ -2308,13 +3526,13 @@ test menu-25.10 {TkSetWindowMenuBar} {
wm geometry .t2 +0+0
toplevel .t3 -menu .m1
wm geometry .t3 +0+0
- list [catch {.t2 configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .t3 .m1 .m2]
-} {0 {} {} {}}
-test menu-25.11 {TkSetWindowMenuBar} {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .t2}
- catch {destroy .t3}
+ list [.t2 configure -menu .m2] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.11 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
. configure -menu ""
menu .m1
menu .m2
@@ -2323,128 +3541,188 @@ test menu-25.11 {TkSetWindowMenuBar} {
wm geometry .t2 +0+0
toplevel .t3 -menu .m1
wm geometry .t3 +0+0
- list [catch {. configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .t3 .m1 .m2]
-} {0 {} {} {}}
-test menu-25.12 {TkSetWindowMenuBar} {
- catch {destroy .m1}
+ list [. configure -menu .m2] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.12 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
. configure -menu ""
menu .m1
- list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test menu-25.13 {TkSetWindowMenuBar} {
+ list [. configure -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.13 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
. configure -menu ""
- list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""]
-} {0 {} {}}
-test menu-25.14 {TkSetWindowMenuBar} {
- catch {destroy .m1}
+ list [. configure -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.14 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
. configure -menu ""
menu .m1
- list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test menu-25.15 {TkSetWindowMenuBar} {
+ list [. configure -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.15 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
. configure -menu ""
- list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""]
-} {0 {} {}}
-test menu-25.16 {TkSetWindowMenuBar} {
- catch {destroy .m1}
+ list [. configure -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menu-25.16 {TkSetWindowMenuBar} -setup {
+ deleteWindows
+} -body {
. configure -menu ""
menu .m1
. configure -menu .m1
- list [catch {toplevel .t2 -menu m1} msg] $msg [. configure -menu ""] [destroy .t2 .m1]
-} {0 .t2 {} {}}
+ list [toplevel .t2 -menu m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {.t2 {}}
+
-test menu-26.1 {DestroyMenuHashTable} {
- catch {interp destroy testinterp}
+test menu-26.1 {DestroyMenuHashTable} -setup {
+ catch {interp delete testinterp}
+ deleteWindows
+} -body {
interp create testinterp
load {} Tk testinterp
interp eval testinterp {menu .m1}
- list [catch {interp delete testinterp} msg] $msg
-} {0 {}}
+ interp delete testinterp
+} -returnCodes ok -result {}
+
-test menu-27.1 {GetMenuHashTable} {
- catch {interp destroy testinterp}
+test menu-27.1 {GetMenuHashTable} -setup {
+ catch {interp delete testinterp}
+ deleteWindows
+} -body {
interp create testinterp
load {} Tk testinterp
list [catch {interp eval testinterp {menu .m1}} msg] $msg [interp delete testinterp]
-} {0 .m1 {}}
+} -cleanup {
+ deleteWindows
+} -result {0 .m1 {}}
-test menu-28.1 {TkCreateMenuReferences - not there before} {
- catch {destroy .m1}
- list [catch {menu .m1} msg] $msg [destroy .m1]
-} {0 .m1 {}}
-test menu-28.2 {TkCreateMenuReferences - there already} {
- catch {destroy .m1}
- catch {destroy .m2}
+
+test menu-28.1 {TkCreateMenuReferences - not there before} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+} -cleanup {
+ deleteWindows
+} -result {.m1}
+test menu-28.2 {TkCreateMenuReferences - there already} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add cascade -menu .m2
- list [catch {menu .m2} msg] $msg [destroy .m1 .m2]
-} {0 .m2 {}}
+ menu .m2
+} -cleanup {
+ deleteWindows
+} -result {.m2}
-test menu-29.1 {TkFindMenuReferences - not there} {
- catch {destroy .m1}
+
+test menu-29.1 {TkFindMenuReferences - not there} -setup {
+ deleteWindows
+} -body {
. configure -menu ""
menu .m1
.m1 add cascade -menu .m2
- list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test menu-30.1 {TkFindMenuReferences - there already} {
- catch {destroy .m1}
- catch {destroy .m2}
+ list [. configure -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+
+
+test menu-30.1 {TkFindMenuReferences - there already} -setup {
+ deleteWindows
+} -body {
. configure -menu ""
menu .m1
menu .m2
.m1 add cascade -menu .m2
- list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1 .m2]
-} {0 {} {} {}}
+ list [. configure -menu .m1] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+
-test menu-31.1 {TkFreeMenuReferences - menuPtr} {
- catch {destroy .m1}
+test menu-31.1 {TkFreeMenuReferences - menuPtr} -setup {
+ deleteWindows
+} -body {
menu .m1
- list [catch {destroy .m1} msg] $msg
-} {0 {}}
-test menu-31.2 {TkFreeMenuReferences - cascadePtr} {
- catch {destroy .m1}
+ destroy .m1
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-31.2 {TkFreeMenuReferences - cascadePtr} -setup {
+ deleteWindows
+} -body {
. configure -menu ""
menu .m1
.m1 add cascade -menu .m2
- list [catch {.m1 entryconfigure 1 -menu .m3} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-31.3 {TkFreeMenuReferences - topLevelListPtr} {
+ .m1 entryconfigure 1 -menu .m3
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-31.3 {TkFreeMenuReferences - topLevelListPtr} -setup {
+ deleteWindows
+} -body {
. configure -menu .m1
- list [catch {. configure -menu ""} msg] $msg
-} {0 {}}
-test menu-31.4 {TkFreeMenuReferences - not empty} {
- catch {destroy .m1}
- catch {destroy .m2}
+ . configure -menu ""
+} -cleanup {
+ deleteWindows
+} -returnCodes ok -result {}
+test menu-31.4 {TkFreeMenuReferences - not empty} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add cascade -menu .m3
menu .m2
.m2 add cascade -menu .m3
- list [catch {.m2 entryconfigure 1 -menu ".foo"} msg] $msg [destroy .m1 .m2]
-} {0 {} {}}
+ .m2 entryconfigure 1 -menu ".foo"
+} -cleanup {
+ deleteWindows
+} -result {}
+
-test menu-32.1 {DeleteMenuCloneEntries} {
- catch {destroy .m1}
- catch {destroy .m2}
+test menu-32.1 {DeleteMenuCloneEntries} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label foo
.m1 clone .m2
- list [catch {.m1 delete 1} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-32.2 {DeleteMenuCloneEntries} {
- catch {destroy .m1}
- catch {destroy .m2}
+ .m1 delete 1
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-32.2 {DeleteMenuCloneEntries} -setup {
+ deleteWindows
+} -body {
+
menu .m1
.m1 add command -label one
.m1 add command -label two
.m1 add command -label three
.m1 add command -label four
.m1 clone .m2
- list [catch {.m1 delete 2 3} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-32.3 {DeleteMenuCloneEntries} {
- catch {destroy .m1}
- catch {destroy .m2}
+ .m1 delete 2 3
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-32.3 {DeleteMenuCloneEntries} -setup {
+ deleteWindows
+} -body {
menu .m1 -tearoff 0
.m1 add command -label one
.m1 add command -label two
@@ -2452,11 +3730,13 @@ test menu-32.3 {DeleteMenuCloneEntries} {
.m1 add command -label four
.m1 clone .m2
.m2 configure -tearoff 1
- list [catch {.m1 delete 1 2} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-32.4 {DeleteMenuCloneEntries} {
- catch {destroy .m1}
- catch {destroy .m2}
+ .m1 delete 1 2
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-32.4 {DeleteMenuCloneEntries} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label one
.m1 add command -label two
@@ -2464,49 +3744,62 @@ test menu-32.4 {DeleteMenuCloneEntries} {
.m1 add command -label four
.m1 clone .m2
.m2 configure -tearoff 0
- list [catch {.m1 delete 2 3} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-32.5 {DeleteMenuCloneEntries} {
- catch {destroy .m1}
- catch {destroy .m2}
+ .m1 delete 2 3
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-32.5 {DeleteMenuCloneEntries} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label one
.m1 add command -label two
.m1 clone .m2
.m1 activate one
- list [catch {.m1 delete one} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-32.6 {DeleteMenuCloneEntries - reentrancy - crashes tk8.0} {
- catch {destroy .m1}
- menu .m1
- .m1 add command -label test -command ".m1 delete test ; .m1 add command -label test -command \".m1 delete test\"; .m1 delete test"
- list [catch {.m1 invoke test} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-32.7 {DeleteMenuCloneEntries - one entry} {
- catch {destroy .m1}
+ .m1 delete one
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-32.6 {DeleteMenuCloneEntries - reentrancy - crashes tk8.0} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label test \
+ -command ".m1 delete test ; .m1 add command -label test -command \".m1 delete test\"; .m1 delete test"
+ .m1 invoke test
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-32.7 {DeleteMenuCloneEntries - one entry} -setup {
+ deleteWindows
+} -body {
menu .m1 -tearoff 0
.m1 add command -label Hello
- list [catch {.m1 delete Hello} msg] $msg [destroy .m1]
-} {0 {} {}}
-test menu-32.8 {Ensure all menu clone commands are deleted} {
+ .m1 delete Hello
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-32.8 {Ensure all menu clone commands are deleted} -setup {
+ deleteWindows
+} -body {
# SF bug #465324
- catch {destroy .menubar}
- catch {destroy .menubar.test}
menu .menubar
. configure -menu .menubar
menu .menubar.test
.menubar.test add command -label "hi"
for {set i 0} {$i < 10} {incr i} {
- .menubar add cascade -menu .menubar.test -label "Test"
- .menubar delete Test
+ .menubar add cascade -menu .menubar.test -label "Test"
+ .menubar delete Test
}
info commands .#menubar*test*
-} {}
-test menu-32.9 {Ensure deleting of clones doesn't corrupt menu refs} {
- catch {destroy .menubar}
- catch {destroy .menubar.test}
-
+} -cleanup {
+ deleteWindows
+} -result {}
+test menu-32.9 {Ensure deleting of clones doesn't corrupt menu refs} -setup {
+ set res {}
+ deleteWindows
+} -body {
menu .menubar
. configure -menu .menubar
menu .menubar.test
@@ -2514,7 +3807,6 @@ test menu-32.9 {Ensure deleting of clones doesn't corrupt menu refs} {
menu .menubar.cascade
.menubar.test add cascade -menu .menubar.cascade -label "Cascade"
- set res {}
lappend res [.menubar.test entrycget 1 -menu]
lappend res [.#menubar.#menubar#test entrycget 1 -menu]
destroy .menubar.test
@@ -2522,46 +3814,60 @@ test menu-32.9 {Ensure deleting of clones doesn't corrupt menu refs} {
.menubar.test add cascade -menu .menubar.cascade -label "Cascade"
lappend res [.menubar.test entrycget 1 -menu]
lappend res [.#menubar.#menubar#test entrycget 1 -menu]
- set res
-} {.menubar.cascade .#menubar.#menubar#test.#menubar#cascade .menubar.cascade .#menubar.#menubar#test.#menubar#cascade}
+ return $res
+} -cleanup {
+ deleteWindows
+} -result {.menubar.cascade .#menubar.#menubar#test.#menubar#cascade .menubar.cascade .#menubar.#menubar#test.#menubar#cascade}
-set l [interp hidden]
-deleteWindows
-test menu-33.1 {menu vs command hiding} {
- catch {destroy .m}
+test menu-33.1 {menu vs command hiding} -setup {
+ deleteWindows
+} -body {
+ set l [interp hidden]
menu .m
interp hide {} .m
destroy .m
- list [winfo children .] [interp hidden]
-} [list {} $l]
+ set result [list [winfo children .] [interp hidden]]
+ expr {$result eq [list {} $l]}
+} -result 1
# menu-34 MenuInit only called at boot time
# creating menus on two different screens then deleting the
# menu from the first screen crashes Tk8.3.1
#
-test menu-35.1 {menus on multiple screens - crashes tk8.3.1, Bug 5454} \
- {altDisplay} {
+test menu-34.1 {menus on multiple screens - crashes tk8.3.1, Bug 5454} -constraints {
+ altDisplay
+} -setup {
+ deleteWindows
+} -body {
toplevel .one
menu .one.m
toplevel .two -screen $::env(TK_ALT_DISPLAY)
menu .two.m
destroy .one
destroy .two
-} {}
+} -result {}
-test menu-36.1 {menu -underline string overruns Bug 1599877} {} {
+test menu-35.1 {menu -underline string overruns Bug 1599877} -setup {
+ destroy .m
+} -body {
# ensure that -underline does not do string overruns [Bug 1599877]
- catch {destroy .m}
menu .m
.m add command -label "File" -underline [expr {1<<30}]
. configure -menu .m
update
tk::TraverseToMenu . "e"
-} {}
+} -cleanup {
+ deleteWindows
+} -result {}
# cleanup
+imageFinish
deleteWindows
cleanupTests
return
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tests/menuDraw.test b/tests/menuDraw.test
index 225223c..bb632c6 100644
--- a/tests/menuDraw.test
+++ b/tests/menuDraw.test
@@ -5,173 +5,260 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
+namespace import -force tcltest::test
+imageInit
-test menuDraw-1.1 {TkMenuInitializeDrawingFields} {
- catch {destroy .m1}
- list [menu .m1] [destroy .m1]
-} {.m1 {}}
-
-test menuDraw-2.1 {TkIntializeMenuEntryDrawingFields} {
- catch {destroy .m1}
+test menuDraw-1.1 {TkMenuInitializeDrawingFields} -setup {
+ deleteWindows
+} -body {
menu .m1
- list [.m1 add command] [destroy .m1]
-} {{} {}}
+} -cleanup {
+ deleteWindows
+} -result {.m1}
+
+
+test menuDraw-2.1 {TkIntializeMenuEntryDrawingFields} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command
+} -cleanup {
+ deleteWindows
+} -result {}
+
-test menuDraw-3.1 {TkMenuFreeDrawOptions} {
- catch {destroy .m1}
+test menuDraw-3.1 {TkMenuFreeDrawOptions} -setup {
+ deleteWindows
+} -body {
menu .m1
- list [destroy .m1]
-} {{}}
+ destroy .m1
+} -result {}
-test menuDraw-4.1 {TkMenuEntryFreeDrawOptions} {
- catch {destroy .m1}
+
+test menuDraw-4.1 {TkMenuEntryFreeDrawOptions} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "This is a test"
- list [destroy .m1]
-} {{}}
-test menuDraw-4.2 {TkMenuEntryFreeDrawOptions} {
- catch {destroy .m1}
- menu .m1
- .m1 add checkbutton -label "This is a test." -font "Courier 12" -activeforeground red -background green -selectcolor purple
- list [destroy .m1]
-} {{}}
-
-test menuDraw-5.1 {TkMenuConfigureDrawOptions - new menu} {
- catch {destroy .m1}
- list [menu .m1] [destroy .m1]
-} {.m1 {}}
-test menuDraw-5.2 {TkMenuConfigureDrawOptions - old menu} {
- catch {destroy .m1}
- menu .m1
- list [.m1 configure -fg red] [destroy .m1]
-} {{} {}}
-test menuDraw-5.3 {TkMenuConfigureDrawOptions - no disabledFg} {
- catch {destroy .m1}
- list [menu .m1 -disabledforeground ""] [destroy .m1]
-} {.m1 {}}
-
-test menuDraw-6.1 {TkMenuConfigureEntryDrawOptions - no tkfont specified} {
- catch {destroy .m1}
- menu .m1
- list [.m1 add command -label "foo"] [destroy .m1]
-} {{} {}}
-test menuDraw-6.2 {TkMenuConfigureEntryDrawOptions - tkfont specified} {
- catch {destroy .m1}
- menu .m1
- list [.m1 add command -label "foo" -font "Courier 12"] [destroy .m1]
-} {{} {}}
-test menuDraw-6.3 {TkMenuConfigureEntryDrawOptions - active state - wrong entry} {
- catch {destroy .m1}
+ destroy .m1
+} -result {}
+test menuDraw-4.2 {TkMenuEntryFreeDrawOptions} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add checkbutton -label "This is a test." -font "Courier 12" \
+ -activeforeground red -background green -selectcolor purple
+ destroy .m1
+} -result {}
+
+
+test menuDraw-5.1 {TkMenuConfigureDrawOptions - new menu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+} -cleanup {
+ deleteWindows
+} -result {.m1}
+test menuDraw-5.2 {TkMenuConfigureDrawOptions - old menu} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 configure -fg red
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-5.3 {TkMenuConfigureDrawOptions - no disabledFg} -setup {
+ deleteWindows
+} -body {
+ menu .m1 -disabledforeground ""
+} -cleanup {
+ deleteWindows
+} -result {.m1}
+
+
+test menuDraw-6.1 {TkMenuConfigureEntryDrawOptions - no tkfont specified} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "foo"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.2 {TkMenuConfigureEntryDrawOptions - tkfont specified} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "foo" -font "Courier 12"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.3 {TkMenuConfigureEntryDrawOptions - active state - wrong entry} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "foo"
- list [.m1 entryconfigure 1 -state active] [destroy .m1]
-} {{} {}}
-test menuDraw-6.4 {TkMenuConfigureEntryDrawOptions - active state - correct entry} {
- catch {destroy .m1}
+ .m1 entryconfigure 1 -state active
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.4 {TkMenuConfigureEntryDrawOptions - active state - correct entry} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "foo"
.m1 activate 1
- list [.m1 entryconfigure 1 -state active] [destroy .m1]
-} {{} {}}
-test menuDraw-6.5 {TkMenuConfigureEntryDrawOptions - deactivate entry} {
- catch {destroy .m1}
+ .m1 entryconfigure 1 -state active
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.5 {TkMenuConfigureEntryDrawOptions - deactivate entry} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "foo"
.m1 activate 1
- list [.m1 entryconfigure 1 -state normal] [destroy .m1]
-} {{} {}}
-test menuDraw-6.6 {TkMenuConfigureEntryDrawOptions - bad state} {
- catch {destroy .m1}
+ .m1 entryconfigure 1 -state normal
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.6 {TkMenuConfigureEntryDrawOptions - bad state} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "foo"
- list [catch {.m1 entryconfigure 1 -state foo} msg] $msg [destroy .m1]
-} {1 {bad state "foo": must be active, normal, or disabled} {}}
-test menuDraw-6.7 {TkMenuConfigureEntryDrawOptions - tkfont specified} {
- catch {destroy .m1}
- menu .m1
- list [.m1 add command -label "foo" -font "Courier 12"] [destroy .m1]
-} {{} {}}
-test menuDraw-6.8 {TkMenuConfigureEntryDrawOptions - border specified} {
- catch {destroy .m1}
- menu .m1
- list [.m1 add command -label "foo" -background "red"] [destroy .m1]
-} {{} {}}
-test menuDraw-6.9 {TkMenuConfigureEntryDrawOptions - foreground specified} {
- catch {destroy .m1}
- menu .m1
- list [.m1 add command -label "foo" -foreground "red"] [destroy .m1]
-} {{} {}}
-test menuDraw-6.10 {TkMenuConfigureEntryDrawOptions - activeBorder specified} {
- catch {destroy .m1}
- menu .m1
- list [.m1 add command -label "foo" -activebackground "red"] [destroy .m1]
-} {{} {}}
-test menuDraw-6.11 {TkMenuConfigureEntryDrawOptions - activeforeground specified} {
- catch {destroy .m1}
- menu .m1
- list [.m1 add command -label "foo" -activeforeground "red"] [destroy .m1]
-} {{} {}}
-test menuDraw-6.12 {TkMenuConfigureEntryDrawOptions - selectcolor specified} {
- catch {destroy .m1}
- menu .m1
- list [.m1 add radiobutton -label "foo" -selectcolor "red"] [destroy .m1]
-} {{} {}}
-test menuDraw-6.13 {TkMenuConfigureEntryDrawOptions - textGC disposal} {
- catch {destroy .m1}
+ .m1 entryconfigure 1 -state foo
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {bad state "foo": must be active, normal, or disabled}
+test menuDraw-6.7 {TkMenuConfigureEntryDrawOptions - tkfont specified} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "foo" -font "Courier 12"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.8 {TkMenuConfigureEntryDrawOptions - border specified} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "foo" -background "red"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.9 {TkMenuConfigureEntryDrawOptions - foreground specified} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "foo" -foreground "red"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.10 {TkMenuConfigureEntryDrawOptions - activeBorder specified} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "foo" -activebackground "red"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.11 {TkMenuConfigureEntryDrawOptions - activeforeground specified} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add command -label "foo" -activeforeground "red"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.12 {TkMenuConfigureEntryDrawOptions - selectcolor specified} -setup {
+ deleteWindows
+} -body {
+ menu .m1
+ .m1 add radiobutton -label "foo" -selectcolor "red"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.13 {TkMenuConfigureEntryDrawOptions - textGC disposal} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "foo" -font "Helvetica 12"
- list [.m1 entryconfigure 1 -font "Courier 12"] [destroy .m1]
-} {{} {}}
-test menuDraw-6.14 {TkMenuConfigureEntryDrawOptions - activeGC disposal} {
- catch {destroy .m1}
+ .m1 entryconfigure 1 -font "Courier 12"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.14 {TkMenuConfigureEntryDrawOptions - activeGC disposal} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "foo" -activeforeground "red"
- list [.m1 entryconfigure 1 -activeforeground "green"] [destroy .m1]
-} {{} {}}
-test menuDraw-6.15 {TkMenuConfigureEntryDrawOptions - disabledGC disposal} {
- catch {destroy .m1}
+ .m1 entryconfigure 1 -activeforeground "green"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.15 {TkMenuConfigureEntryDrawOptions - disabledGC disposal} -setup {
+ deleteWindows
+} -body {
menu .m1 -disabledforeground "red"
.m1 add command -label "foo"
- list [.m1 configure -disabledforeground "green"] [destroy .m1]
-} {{} {}}
-test menuDraw-6.16 {TkMenuConfigureEntryDrawOptions - indicatorGC disposal} {
- catch {destroy .m1}
+ .m1 configure -disabledforeground "green"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-6.16 {TkMenuConfigureEntryDrawOptions - indicatorGC disposal} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add radiobutton -label "foo" -selectcolor "red"
- list [.m1 entryconfigure 1 -selectcolor "green"] [destroy .m1]
-} {{} {}}
+ .m1 entryconfigure 1 -selectcolor "green"
+} -cleanup {
+ deleteWindows
+} -result {}
-test menuDraw-7.1 {TkEventuallyRecomputeMenu} {
- catch {destroy .m1}
+
+test menuDraw-7.1 {TkEventuallyRecomputeMenu} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "This is a long label"
set tearoff [tk::TearOffMenu .m1]
update idletasks
- list [.m1 entryconfigure 1 -label "foo"] [destroy .m1]
-} {{} {}}
-test menuDraw-7.2 {TkEventuallyRecomputeMenu - update pending} {
- catch {destroy .m1}
+ .m1 entryconfigure 1 -label "foo"
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-7.2 {TkEventuallyRecomputeMenu - update pending} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "This is a long label"
set tearoff [tk::TearOffMenu .m1]
- list [.m1 entryconfigure 1 -label "foo"] [destroy .m1]
-} {{} {}}
+ .m1 entryconfigure 1 -label "foo"
+} -cleanup {
+ deleteWindows
+} -result {}
-test menuDraw-8.1 {TkRecomputeMenu} {win userInteraction} {
- catch {destroy .m1}
+test menuDraw-8.1 {TkRecomputeMenu} -constraints {
+ win userInteraction
+} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 configure -postcommand [.m1 add command -label foo]
.m1 add command -label "Hit ESCAPE to make this menu go away."
- list [.m1 post 0 0] [destroy .m1]
-} {{} {}}
+ .m1 post 0 0
+} -cleanup {
+ deleteWindows
+} -result {}
-test menuDraw-9.1 {TkEventuallyRedrawMenu - entry test} {
- catch {destroy .m1}
+test menuDraw-9.1 {TkEventuallyRedrawMenu - entry test} -setup {
+ deleteWindows
+} -body {
catch {unset foo}
menu .m1
set foo 0
@@ -179,46 +266,66 @@ test menuDraw-9.1 {TkEventuallyRedrawMenu - entry test} {
tk::TearOffMenu .m1
update idletasks
list [set foo test] [destroy .m1] [unset foo]
-} {test {} {}}
-test menuDraw-9.2 {TkEventuallyRedrawMenu - whole menu} {
- catch {destroy .m1}
+} -result {test {} {}}
+test menuDraw-9.2 {TkEventuallyRedrawMenu - whole menu} -setup {
+ deleteWindows
+} -body {
menu .m1
- list [catch {tk::TearOffMenu .m1}] [destroy .m1]
-} {0 {}}
+ tk::TearOffMenu .m1
+} -cleanup {
+ deleteWindows
+} -returnCodes ok -match glob -result *
+
# Don't know how to test when window has been deleted and ComputeMenuGeometry
# gets called.
-test menuDraw-10.1 {ComputeMenuGeometry - menubar} {
- catch {destroy .m1}
+test menuDraw-10.1 {ComputeMenuGeometry - menubar} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label test
. configure -menu .m1
- list [update idletasks] [. configure -menu ""] [destroy .m1]
-} {{} {} {}}
-test menuDraw-10.2 {ComputeMenuGeometry - non-menubar} {
- catch {destroy .m1}
+ list [update idletasks] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menuDraw-10.2 {ComputeMenuGeometry - non-menubar} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label test
- list [update idletasks] [destroy .m1]
-} {{} {}}
-test menuDraw-10.3 {ComputeMenuGeometry - Resize necessary} {
- catch {destroy .m1}
+ update idletasks
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-10.3 {ComputeMenuGeometry - Resize necessary} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label test
- list [update idletasks] [destroy .m1]
-} {{} {}}
-test menuDraw-10.4 {ComputeMenuGeometry - resize not necessary} {
- catch {destroy .m1}
+ update idletasks
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-10.4 {ComputeMenuGeometry - resize not necessary} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label test
update idletasks
.m1 entryconfigure 1 -label test
- list [update idletasks] [destroy .m1]
-} {{} {}}
+ update idletasks
+} -cleanup {
+ deleteWindows
+} -result {}
-test menuDraw-11.1 {TkMenuSelectImageProc - entry selected; redraw not pending} testImageType {
- catch {destroy .m1}
- catch {eval image delete [image names]}
+
+test menuDraw-11.1 {TkMenuSelectImageProc - entry selected; redraw not pending} -constraints {
+ testImageType
+} -setup {
+ deleteWindows
+ imageCleanup
+} -body {
image create test image1
image create test image2
menu .m1
@@ -226,80 +333,111 @@ test menuDraw-11.1 {TkMenuSelectImageProc - entry selected; redraw not pending}
.m1 invoke 1
set tearoff [tk::TearOffMenu .m1 40 40]
update idletasks
- list [image delete image2] [destroy .m1] [eval image delete [image names]]
-} {{} {} {}}
-test menuDraw-11.2 {TkMenuSelectImageProc - entry selected; redraw pending} testImageType {
- catch {destroy .m1}
- catch {eval image delete [image names]}
+ list [image delete image2] [destroy .m1]
+} -cleanup {
+ imageCleanup
+} -result {{} {}}
+test menuDraw-11.2 {TkMenuSelectImageProc - entry selected; redraw pending} -constraints {
+ testImageType
+} -setup {
+ deleteWindows
+ imageCleanup
+} -body {
image create test image1
image create test image2
menu .m1
.m1 add checkbutton -image image1 -selectimage image2
.m1 invoke 1
set tearoff [tk::TearOffMenu .m1 40 40]
- list [image delete image2] [destroy .m1] [eval image delete [image names]]
-} {{} {} {}}
-test menuDraw-11.3 {TkMenuSelectImageProc - entry not selected} testImageType {
- catch {destroy .m1}
- catch {eval image delete [image names]}
+ list [image delete image2] [destroy .m1]
+} -cleanup {
+ imageCleanup
+} -result {{} {}}
+test menuDraw-11.3 {TkMenuSelectImageProc - entry not selected} -constraints {
+ testImageType
+} -setup {
+ deleteWindows
+ imageCleanup
+} -body {
image create test image1
image create test image2
menu .m1
.m1 add checkbutton -image image1 -selectimage image2
set tearoff [tk::TearOffMenu .m1 40 40]
update idletasks
- list [image delete image2] [destroy .m1] [eval image delete [image names]]
-} {{} {} {}}
+ list [image delete image2] [destroy .m1]
+} -cleanup {
+ imageCleanup
+} -result {{} {}}
#Don't know how to test missing tkwin in DisplayMenu
-test menuDraw-12.1 {DisplayMenu - menubar background} unix {
- catch {destroy .m1}
+test menuDraw-12.1 {DisplayMenu - menubar background} -constraints unix -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add cascade -label foo -menu .m2
. configure -menu .m1
- list [update] [. configure -menu ""] [destroy .m1]
-} {{} {} {}}
-test menuDraw-12.2 {Display menu - no entries} {
- catch {destroy .m1}
+ list [update] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menuDraw-12.2 {Display menu - no entries} -setup {
+ deleteWindows
+} -body {
menu .m1
set tearoff [tk::TearOffMenu .m1 40 40]
- list [update] [destroy .m1]
-} {{} {}}
-test menuDraw-12.3 {DisplayMenu - one entry} {
- catch {destroy .m1}
+ update
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-12.3 {DisplayMenu - one entry} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label foo
set tearoff [tk::TearOffMenu .m1 40 40]
- list [update] [destroy .m1]
-} {{} {}}
-test menuDraw-12.4 {DisplayMenu - two entries} {
- catch {destroy .m1}
+ update
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-12.4 {DisplayMenu - two entries} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "one"
.m1 add command -label "two"
set tearoff [tk::TearOffMenu .m1 40 40]
- list [update] [destroy .m1]
-} {{} {}}
-test menuDraw.12.5 {DisplayMenu - two columns - first bigger} {
- catch {destroy .m1}
+ update
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw.12.5 {DisplayMenu - two columns - first bigger} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "one"
.m1 add command -label "two"
.m1 add command -label "three" -columnbreak 1
set tearoff [tk::TearOffMenu .m1 40 40]
- list [update] [destroy .m1]
-} {{} {}}
-test menuDraw-12.5 {DisplayMenu - two column - second bigger} {
- catch {destroy .m1}
+ update
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-12.5 {DisplayMenu - two column - second bigger} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "one"
.m1 add command -label "two" -columnbreak 1
.m1 add command -label "three"
set tearoff [tk::TearOffMenu .m1 40 40]
- list [update] [destroy .m1]
-} {{} {}}
-test menuDraw.12.7 {DisplayMenu - three columns} {
- catch {destroy .m1}
+ update
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw.12.7 {DisplayMenu - three columns} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "one"
.m1 add command -label "two" -columnbreak 1
@@ -308,133 +446,175 @@ test menuDraw.12.7 {DisplayMenu - three columns} {
.m1 add command -label "five"
.m1 add command -label "six"
set tearoff [tk::TearOffMenu .m1 40 40]
- list [update] [destroy .m1]
-} {{} {}}
-test menuDraw-12.6 {Display menu - testing for extra space and menubars} unix {
- catch {destroy .m1}
+ update
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-12.6 {Display menu - testing for extra space and menubars} -constraints {
+ unix
+} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add cascade -label foo
. configure -menu .m1
- list [update] [. configure -menu ""] [destroy .m1]
-} {{} {} {}}
-test menuDraw-12.7 {Display menu - extra space at end of menu} {
- catch {destroy .m1}
+ update
+ . configure -menu ""
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-12.7 {Display menu - extra space at end of menu} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add cascade -label foo
set tearoff [tk::TearOffMenu .m1 40 40]
wm geometry $tearoff 200x100
- list [update] [destroy .m1]
-} {{} {}}
+ update
+} -cleanup {
+ deleteWindows
+} -result {}
+
-test menuDraw-13.1 {TkMenuEventProc - Expose} {
- catch {destroy .m1}
- catch {destroy .m2}
+test menuDraw-13.1 {TkMenuEventProc - Expose} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "one"
menu .m2
.m2 add command -label "two"
set tearoff1 [tk::TearOffMenu .m1 40 40]
set tearoff2 [tk::TearOffMenu .m2 40 40]
- list [raise $tearoff2] [update] [destroy .m1] [destroy .m2]
-} {{} {} {} {}}
-test menuDraw-13.2 {TkMenuEventProc - ConfigureNotify} {
- catch {destroy .m1}
+ list [raise $tearoff2] [update]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menuDraw-13.2 {TkMenuEventProc - ConfigureNotify} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "foo"
set tearoff [tk::TearOffMenu .m1 40 40]
- list [wm geometry $tearoff 200x100] [update] [destroy .m1]
-} {{} {} {}}
+ list [wm geometry $tearoff 200x100] [update]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
# Testing deletes is hard, and I am going to do my best. Don't know how
# to test the case where we have already cleared the tkwin field in the
# menuPtr.
-test menuDraw-13.4 {TkMenuEventProc - simple delete} {
- catch {destroy .m1}
+test menuDraw-13.4 {TkMenuEventProc - simple delete} -setup {
+ deleteWindows
+} -body {
menu .m1
- list [destroy .m1]
-} {{}}
-test menuDraw-13.5 {TkMenuEventProc - nothing pending} {
- catch {destroy .m1}
+ destroy .m1
+} -result {}
+test menuDraw-13.5 {TkMenuEventProc - nothing pending} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label foo
update idletasks
- list [destroy .m1]
-} {{}}
+ destroy .m1
+} -result {}
-test menuDraw-14.1 {TkMenuImageProc} testImageType {
- catch {destroy .m1}
+
+test menuDraw-14.1 {TkMenuImageProc} -constraints testImageType -setup {
+ deleteWindows
+} -body {
catch {image delete image1}
menu .m1
image create test image1
.m1 add command -image image1
update idletasks
- list [image delete image1] [destroy .m1]
-} {{} {}}
-test menuDraw-14.2 {TkMenuImageProc} testImageType {
- catch {destroy .m1}
+ image delete image1
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-14.2 {TkMenuImageProc} -constraints testImageType -setup {
+ deleteWindows
+} -body {
catch {image delete image1}
menu .m1
image create test image1
.m1 add command -image image1
- list [image delete image1] [destroy .m1]
-} {{} {}}
+ image delete image1
+} -cleanup {
+ deleteWindows
+} -result {}
+
-test menuDraw-15.1 {TkPostTearoffMenu - Basic posting} {
- catch {destroy .m1}
+test menuDraw-15.1 {TkPostTearoffMenu - Basic posting} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "foo"
- list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1]
-} {0 {}}
-test menuDraw-15.2 {TkPostTearoffMenu - Deactivation} {
- catch {destroy .m1}
+ tk::TearOffMenu .m1 40 40
+} -cleanup {
+ deleteWindows
+} -returnCodes ok -match glob -result *
+test menuDraw-15.2 {TkPostTearoffMenu - Deactivation} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "foo" -state active
set tearoff [tk::TearOffMenu .m1 40 40]
- list [$tearoff index active] [destroy .m1]
-} {none {}}
-test menuDraw-15.3 {TkPostTearoffMenu - post command} {
- catch {destroy .m1}
+ $tearoff index active
+} -cleanup {
+ deleteWindows
+} -result {none}
+test menuDraw-15.3 {TkPostTearoffMenu - post command} -setup {
+ deleteWindows
+} -body {
catch {unset foo}
menu .m1 -postcommand "set foo .m1"
.m1 add command -label "foo"
list [catch {tk::TearOffMenu .m1 40 40}] [set foo] [unset foo] [destroy .m1]
-} {0 .m1 {} {}}
-test menuDraw-15.4 {TkPostTearoffMenu - post command deleting the menu} {
- catch {destroy .m1}
+} -result {0 .m1 {} {}}
+test menuDraw-15.4 {TkPostTearoffMenu - post command deleting the menu} -setup {
+ deleteWindows
+} -body {
menu .m1 -postcommand "destroy .m1"
.m1 add command -label "foo"
list [catch {tk::TearOffMenu .m1 40 40} msg] $msg [winfo exists .m1]
-} {0 {} 0}
-test menuDraw-15.5 {TkPostTearoffMenu - tearoff at edge of screen} {
- catch {destroy .m1}
+} -result {0 {} 0}
+test menuDraw-15.5 {TkPostTearoffMenu - tearoff at edge of screen} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "foo"
set height [winfo screenheight .m1]
- list [catch {tk::TearOffMenu .m1 40 $height}] [destroy .m1]
-} {0 {}}
-test menuDraw-15.6 {TkPostTearoffMenu - tearoff off right} {
- catch {destroy .m1}
+ tk::TearOffMenu .m1 40 $height
+} -cleanup {
+ deleteWindows
+} -returnCodes ok -match glob -result *
+test menuDraw-15.6 {TkPostTearoffMenu - tearoff off right} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add command -label "foo"
set width [winfo screenwidth .m1]
- list [catch {tk::TearOffMenu .m1 $width 40}] [destroy .m1]
-} {0 {}}
+ tk::TearOffMenu .m1 $width 40
+} -cleanup {
+ deleteWindows
+} -returnCodes ok -match glob -result *
-test menuDraw-16.1 {TkPostSubmenu} nonUnixUserInteraction {
- catch {destroy .m1}
- catch {destroy .m2}
+test menuDraw-16.1 {TkPostSubmenu} -constraints nonUnixUserInteraction -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add cascade -label test -menu .m2
menu .m2
.m2 add command -label "Hit ESCAPE to make this menu go away."
set tearoff [tk::TearOffMenu .m1 40 40]
$tearoff postcascade 0
- list [$tearoff postcascade 0] [destroy .m1] [destroy .m2]
-} {{} {} {}}
-test menuDraw-16.2 {TkPostSubMenu} nonUnixUserInteraction {
- catch {destroy .m1}
- catch {destroy .m2}
- catch {destroy .m3}
+ $tearoff postcascade 0
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-16.2 {TkPostSubMenu} -constraints nonUnixUserInteraction -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add cascade -label "two" -menu .m2
.m1 add cascade -label "three" -menu .m3
@@ -444,68 +624,94 @@ test menuDraw-16.2 {TkPostSubMenu} nonUnixUserInteraction {
.m3 add command -label "three"
set tearoff [tk::TearOffMenu .m1 40 40]
$tearoff postcascade 0
- list [$tearoff postcascade 1] [destroy .m1] [destroy .m2] [destroy .m3]
-} {{} {} {} {}}
-test menuDraw-16.3 {TkPostSubMenu} {
- catch {destroy .m1}
+ $tearoff postcascade 1
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-16.3 {TkPostSubMenu} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add cascade -label test -menu .m2
- list [.m1 postcascade 1] [destroy .m1]
-} {{} {}}
-test menuDraw-16.4 {TkPostSubMenu} {
- catch {destroy .m1}
+ .m1 postcascade 1
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-16.4 {TkPostSubMenu} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add cascade -label test
set tearoff [tk::TearOffMenu .m1 40 40]
- list [$tearoff postcascade 0] [destroy .m1]
-} {{} {}}
-test menuDraw-16.5 {TkPostSubMenu} unix {
- catch {destroy .m1}
- catch {destroy .m2}
+ $tearoff postcascade 0
+} -cleanup {
+ deleteWindows
+} -result {}
+test menuDraw-16.5 {TkPostSubMenu} -constraints unix -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add cascade -label test -menu .m2
menu .m2 -postcommand "glorp"
set tearoff [tk::TearOffMenu .m1 40 40]
- list [catch {$tearoff postcascade test} msg] $msg [destroy .m1] [destroy .m2]
-} {1 {invalid command name "glorp"} {} {}}
-test menuDraw-16.6 {TkPostSubMenu} {win userInteraction} {
- catch {destroy .m1}
- catch {destroy .m2}
+ $tearoff postcascade test
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {invalid command name "glorp"}
+test menuDraw-16.6 {TkPostSubMenu} -constraints {
+ win userInteraction
+} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add cascade -label test -menu .m2
menu .m2
.m2 add command -label "Hit ESCAPE to get rid of this menu"
set tearoff [tk::TearOffMenu .m1 40 40]
- list [$tearoff postcascade 0] [destroy .m1] [destroy .m2]
-} {{} {} {}}
+ $tearoff postcascade 0
+} -cleanup {
+ deleteWindows
+} -result {}
-test menuDraw-17.1 {AdjustMenuCoords - menubar} unix {
- catch {destroy .m1}
- catch {destroy .m2}
+
+test menuDraw-17.1 {AdjustMenuCoords - menubar} -constraints unix -setup {
+ deleteWindows
+} -body {
menu .m1 -tearoff 0
.m1 add cascade -label test -menu .m2
menu .m2 -tearoff 0
.m2 add command -label foo
. configure -menu .m1
foreach w [winfo children .] {
- if {[$w cget -type] == "menubar"} {
- break
- }
+ if {[$w cget -type] == "menubar"} {
+ break
+ }
}
- list [$w postcascade 0] [. configure -menu ""] [destroy .m1] [destroy .m2]
-} {{} {} {} {}}
-test menuDraw-17.2 {AdjustMenuCoords - menu} {win userInteraction} {
- catch {destroy .m1}
- catch {destroy .m2}
+ list [$w postcascade 0] [. configure -menu ""]
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
+test menuDraw-17.2 {AdjustMenuCoords - menu} -constraints {
+ win userInteraction
+} -setup {
+ deleteWindows
+} -body {
menu .m1
.m1 add cascade -label test -menu .m2
menu .m2
.m2 add command -label "Hit ESCAPE to make this menu go away"
set tearoff [tk::TearOffMenu .m1 40 40]
- list [$tearoff postcascade 0] [destroy .m1] [destroy .m2]
-} {{} {} {}}
+ $tearoff postcascade 0
+} -cleanup {
+ deleteWindows
+} -result {}
# cleanup
+imageFinish
deleteWindows
cleanupTests
return
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tests/menubut.test b/tests/menubut.test
index 3dfa1b5..6efdb0f 100644
--- a/tests/menubut.test
+++ b/tests/menubut.test
@@ -10,9 +10,11 @@
# XXX of a procedure has tests then the whole procedure has tests,
# XXX but many procedures have no tests.
-package require tcltest 2.1
+package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
+namespace import -force tcltest::test
+imageInit
# Create entries in the option database to be sure that geometry options
# like border width have predictable values.
@@ -24,318 +26,737 @@ option add *Button.borderWidth 2
option add *Button.highlightThickness 2
option add *Button.font {Helvetica -12 bold}
-eval image delete [image names]
-if {[testConstraint testImageType]} {
+
+menubutton .mb -text "Test"
+pack .mb
+update
+test menubutton-1.1 {configuration options} -body {
+ .mb configure -activebackground #012345
+ .mb cget -activebackground
+} -cleanup {
+ .mb configure -activebackground [lindex [.mb configure -activebackground] 3]
+} -result {#012345}
+test menubutton-1.2 {configuration options} -body {
+ .mb configure -activebackground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test menubutton-1.3 {configuration options} -body {
+ .mb configure -activeforeground #ff0000
+ .mb cget -activeforeground
+} -cleanup {
+ .mb configure -activeforeground [lindex [.mb configure -activeforeground] 3]
+} -result {#ff0000}
+test menubutton-1.4 {configuration options} -body {
+ .mb configure -activeforeground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test menubutton-1.5 {configuration options} -body {
+ .mb configure -anchor nw
+ .mb cget -anchor
+} -cleanup {
+ .mb configure -anchor [lindex [.mb configure -anchor] 3]
+} -result {nw}
+test menubutton-1.6 {configuration options} -body {
+ .mb configure -anchor bogus
+} -returnCodes error -result {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}
+test menubutton-1.7 {configuration options} -body {
+ .mb configure -background #ff0000
+ .mb cget -background
+} -cleanup {
+ .mb configure -background [lindex [.mb configure -background] 3]
+} -result {#ff0000}
+test menubutton-1.8 {configuration options} -body {
+ .mb configure -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test menubutton-1.9 {configuration options} -body {
+ .mb configure -bd 4
+ .mb cget -bd
+} -cleanup {
+ .mb configure -bd [lindex [.mb configure -bd] 3]
+} -result {4}
+test menubutton-1.10 {configuration options} -body {
+ .mb configure -bd badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test menubutton-1.11 {configuration options} -body {
+ .mb configure -bg #ff0000
+ .mb cget -bg
+} -cleanup {
+ .mb configure -bg [lindex [.mb configure -bg] 3]
+} -result {#ff0000}
+test menubutton-1.12 {configuration options} -body {
+ .mb configure -bg non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test menubutton-1.13 {configuration options} -body {
+ .mb configure -bitmap questhead
+ .mb cget -bitmap
+} -cleanup {
+ .mb configure -bitmap [lindex [.mb configure -bitmap] 3]
+} -result {questhead}
+test menubutton-1.14 {configuration options} -body {
+ .mb configure -bitmap badValue
+} -returnCodes error -result {bitmap "badValue" not defined}
+test menubutton-1.15 {configuration options} -body {
+ .mb configure -borderwidth 1.3
+ .mb cget -borderwidth
+} -cleanup {
+ .mb configure -borderwidth [lindex [.mb configure -borderwidth] 3]
+} -result {1}
+test menubutton-1.16 {configuration options} -body {
+ .mb configure -borderwidth badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test menubutton-1.17 {configuration options} -body {
+ .mb configure -cursor arrow
+ .mb cget -cursor
+} -cleanup {
+ .mb configure -cursor [lindex [.mb configure -cursor] 3]
+} -result {arrow}
+test menubutton-1.18 {configuration options} -body {
+ .mb configure -cursor badValue
+} -returnCodes error -result {bad cursor spec "badValue"}
+test menubutton-1.19 {configuration options} -body {
+ .mb configure -direction below
+ .mb cget -direction
+} -cleanup {
+ .mb configure -direction [lindex [.mb configure -direction] 3]
+} -result {below}
+test menubutton-1.20 {configuration options} -body {
+ .mb configure -direction badValue
+} -returnCodes error -result {bad direction "badValue": must be above, below, flush, left, or right}
+test menubutton-1.21 {configuration options} -body {
+ .mb configure -disabledforeground #00ff00
+ .mb cget -disabledforeground
+} -cleanup {
+ .mb configure -disabledforeground [lindex [.mb configure -disabledforeground] 3]
+} -result {#00ff00}
+test menubutton-1.22 {configuration options} -body {
+ .mb configure -disabledforeground xyzzy
+} -returnCodes error -result {unknown color name "xyzzy"}
+test menubutton-1.23 {configuration options} -body {
+ .mb configure -fg #110022
+ .mb cget -fg
+} -cleanup {
+ .mb configure -fg [lindex [.mb configure -fg] 3]
+} -result {#110022}
+test menubutton-1.24 {configuration options} -body {
+ .mb configure -fg bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test menubutton-1.25 {configuration options} -body {
+ .mb configure -font {Helvetica 12}
+ .mb cget -font
+} -cleanup {
+ .mb configure -font [lindex [.mb configure -font] 3]
+} -result {Helvetica 12}
+test menubutton-1.26 {configuration options} -body {
+ .mb configure -foreground #110022
+ .mb cget -foreground
+} -cleanup {
+ .mb configure -foreground [lindex [.mb configure -foreground] 3]
+} -result {#110022}
+test menubutton-1.27 {configuration options} -body {
+ .mb configure -foreground bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test menubutton-1.28 {configuration options} -body {
+ .mb configure -height 18
+ .mb cget -height
+} -cleanup {
+ .mb configure -height [lindex [.mb configure -height] 3]
+} -result {18}
+test menubutton-1.29 {configuration options} -body {
+ .mb configure -height 20.0
+} -returnCodes error -result {expected integer but got "20.0"}
+test menubutton-1.30 {configuration options} -body {
+ .mb configure -highlightbackground #112233
+ .mb cget -highlightbackground
+} -cleanup {
+ .mb configure -highlightbackground [lindex [.mb configure -highlightbackground] 3]
+} -result {#112233}
+test menubutton-1.31 {configuration options} -body {
+ .mb configure -highlightbackground ugly
+} -returnCodes error -result {unknown color name "ugly"}
+test menubutton-1.32 {configuration options} -body {
+ .mb configure -highlightcolor #110022
+ .mb cget -highlightcolor
+} -cleanup {
+ .mb configure -highlightcolor [lindex [.mb configure -highlightcolor] 3]
+} -result {#110022}
+test menubutton-1.33 {configuration options} -body {
+ .mb configure -highlightcolor bogus
+} -returnCodes error -result {unknown color name "bogus"}
+test menubutton-1.34 {configuration options} -body {
+ .mb configure -highlightthickness 18
+ .mb cget -highlightthickness
+} -cleanup {
+ .mb configure -highlightthickness [lindex [.mb configure -highlightthickness] 3]
+} -result {18}
+test menubutton-1.35 {configuration options} -body {
+ .mb configure -highlightthickness badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test menubutton-1.36 {configuration options} -constraints {
+ testImageType
+} -setup {
+ catch {image delete image1}
+ image create test image1
+} -body {
+ .mb configure -image image1
+ .mb cget -image
+} -cleanup {
+ .mb configure -image [lindex [.mb configure -image] 3]
image create test image1
-}
+} -result {image1}
+test menubutton-1.37 {configuration options} -setup {
+ catch {image delete bogus}
+} -body {
+ .mb configure -image bogus
+} -cleanup {
+ .mb configure -image [lindex [.mb configure -image] 3]
+} -returnCodes error -result {image "bogus" doesn't exist}
+test menubutton-1.38 {configuration options} -body {
+ .mb configure -indicatoron yes
+ .mb cget -indicatoron
+} -cleanup {
+ .mb configure -indicatoron [lindex [.mb configure -indicatoron] 3]
+} -result {1}
+test menubutton-1.39 {configuration options} -body {
+ .mb configure -indicatoron no_way
+} -returnCodes error -result {expected boolean value but got "no_way"}
+test menubutton-1.40 {configuration options} -body {
+ .mb configure -justify right
+ .mb cget -justify
+} -cleanup {
+ .mb configure -justify [lindex [.mb configure -justify] 3]
+} -result {right}
+test menubutton-1.41 {configuration options} -body {
+ .mb configure -justify bogus
+} -returnCodes error -result {bad justification "bogus": must be left, right, or center}
+test menubutton-1.42 {configuration options} -body {
+ .mb configure -menu {any old string}
+ .mb cget -menu
+} -cleanup {
+ .mb configure -menu [lindex [.mb configure -menu] 3]
+} -result {any old string}
+test menubutton-1.43 {configuration options} -body {
+ .mb configure -padx 12
+ .mb cget -padx
+} -cleanup {
+ .mb configure -padx [lindex [.mb configure -padx] 3]
+} -result {12}
+test menubutton-1.44 {configuration options} -body {
+ .mb configure -padx 420x
+} -returnCodes error -result {bad screen distance "420x"}
+test menubutton-1.45 {configuration options} -body {
+ .mb configure -pady 12
+ .mb cget -pady
+} -cleanup {
+ .mb configure -pady [lindex [.mb configure -pady] 3]
+} -result {12}
+test menubutton-1.46 {configuration options} -body {
+ .mb configure -pady 420x
+} -returnCodes error -result {bad screen distance "420x"}
+test menubutton-1.47 {configuration options} -body {
+ .mb configure -relief groove
+ .mb cget -relief
+} -cleanup {
+ .mb configure -relief [lindex [.mb configure -relief] 3]
+} -result {groove}
+test menubutton-1.48 {configuration options} -body {
+ .mb configure -relief 1.5
+} -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+test menubutton-1.49 {configuration options} -body {
+ .mb configure -state normal
+ .mb cget -state
+} -cleanup {
+ .mb configure -state [lindex [.mb configure -state] 3]
+} -result {normal}
+test menubutton-1.50 {configuration options} -body {
+ .mb configure -state bogus
+} -returnCodes error -result {bad state "bogus": must be active, disabled, or normal}
+test menubutton-1.51 {configuration options} -body {
+ .mb configure -takefocus {any string}
+ .mb cget -takefocus
+} -cleanup {
+ .mb configure -takefocus [lindex [.mb configure -takefocus] 3]
+} -result {any string}
+test menubutton-1.52 {configuration options} -body {
+ .mb configure -text {Sample text}
+ .mb cget -text
+} -cleanup {
+ .mb configure -text [lindex [.mb configure -text] 3]
+} -result {Sample text}
+test menubutton-1.53 {configuration options} -body {
+ .mb configure -textvariable i
+ .mb cget -textvariable
+} -cleanup {
+ .mb configure -textvariable [lindex [.mb configure -textvariable] 3]
+} -result {i}
+test menubutton-1.54 {configuration options} -body {
+ .mb configure -underline 5
+ .mb cget -underline
+} -cleanup {
+ .mb configure -underline [lindex [.mb configure -underline] 3]
+} -result {5}
+test menubutton-1.55 {configuration options} -body {
+ .mb configure -underline 3p
+} -returnCodes error -result {expected integer but got "3p"}
+test menubutton-1.56 {configuration options} -body {
+ .mb configure -width 402
+ .mb cget -width
+} -cleanup {
+ .mb configure -width [lindex [.mb configure -width] 3]
+} -result {402}
+test menubutton-1.57 {configuration options} -body {
+ .mb configure -width 3p
+} -returnCodes error -result {expected integer but got "3p"}
+test menubutton-1.58 {configuration options} -body {
+ .mb configure -wraplength 100
+ .mb cget -wraplength
+} -cleanup {
+ .mb configure -wraplength [lindex [.mb configure -wraplength] 3]
+} -result {100}
+test menubutton-1.59 {configuration options} -body {
+ .mb configure -wraplength 6x
+} -returnCodes error -result {bad screen distance "6x"}
+
+
+deleteWindows
menubutton .mb -text "Test"
pack .mb
update
-set i 1
-foreach test {
- {-activebackground #012345 #012345 non-existent
- {unknown color name "non-existent"}}
- {-activeforeground #ff0000 #ff0000 non-existent
- {unknown color name "non-existent"}}
- {-anchor nw nw bogus {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}}
- {-background #ff0000 #ff0000 non-existent
- {unknown color name "non-existent"}}
- {-bd 4 4 badValue {bad screen distance "badValue"}}
- {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}}
- {-bitmap questhead questhead badValue {bitmap "badValue" not defined}}
- {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
- {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
- {-direction below below badValue {bad direction "badValue": must be above, below, flush, left, or right}}
- {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"}}
- {-fg #110022 #110022 bogus {unknown color name "bogus"}}
- {-font {Helvetica 12} {Helvetica 12} {} {font "" doesn't exist}}
- {-foreground #110022 #110022 bogus {unknown color name "bogus"}}
- {-height 18 18 20.0 {expected integer but got "20.0"}}
- {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}}
- {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"}}
- {-highlightthickness 18 18 badValue {bad screen distance "badValue"}}
- {-image image1 image1 bogus {image "bogus" doesn't exist}}
- {-indicatoron yes 1 no_way {expected boolean value but got "no_way"}}
- {-justify right right bogus {bad justification "bogus": must be left, right, or center}}
- {-menu "any old string" "any old string" {} {}}
- {-padx 12 12 420x {bad screen distance "420x"}}
- {-pady 12 12 420x {bad screen distance "420x"}}
- {-relief groove groove 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}}
- {-state normal normal bogus {bad state "bogus": must be active, disabled, or normal}}
- {-takefocus "any string" "any string" {} {}}
- {-text "Sample text" {Sample text} {} {}}
- {-textvariable i i {} {}}
- {-underline 5 5 3p {expected integer but got "3p"}}
- {-width 402 402 3p {expected integer but got "3p"}}
- {-wraplength 100 100 6x {bad screen distance "6x"}}
-} {
- set name [lindex $test 0]
- test menubutton-1.$i {configuration options} testImageType {
- .mb configure $name [lindex $test 1]
- lindex [.mb configure $name] 4
- } [lindex $test 2]
- incr i
- if {[lindex $test 3] != ""} {
- test menubutton-1.$i {configuration options} {
- list [catch {.mb configure $name [lindex $test 3]} msg] $msg
- } [list 1 [lindex $test 4]]
- }
- .mb configure $name [lindex [.mb configure $name] 3]
- incr i
-}
-
-test menubutton-2.1 {Tk_MenubuttonCmd procedure} {
- list [catch {menubutton} msg] $msg
-} {1 {wrong # args: should be "menubutton pathName ?options?"}}
-test menubutton-2.2 {Tk_MenubuttonCmd procedure} {
- list [catch {menubutton foo} msg] $msg
-} {1 {bad window path name "foo"}}
-test menubutton-2.3 {Tk_MenubuttonCmd procedure} {
+test menubutton-2.1 {Tk_MenubuttonCmd procedure} -body {
+ menubutton
+} -returnCodes error -result {wrong # args: should be "menubutton pathName ?-option value ...?"}
+test menubutton-2.2 {Tk_MenubuttonCmd procedure} -body {
+ menubutton foo
+} -returnCodes error -result {bad window path name "foo"}
+test menubutton-2.3 {Tk_MenubuttonCmd procedure} -body {
catch {destroy .mb}
menubutton .mb
winfo class .mb
-} {Menubutton}
-test menubutton-2.4 {Tk_ButtonCmd procedure} {
- catch {destroy .mb}
- list [catch {menubutton .mb -gorp foo} msg] $msg [winfo exists .mb]
-} {1 {unknown option "-gorp"} 0}
+} -result {Menubutton}
+test menubutton-2.4 {Tk_ButtonCmd procedure} -setup {
+ destroy .mb
+} -body {
+ menubutton .mb -gorp foo
+} -returnCodes error -result {unknown option "-gorp"}
+test menubutton-2.5 {Tk_ButtonCmd procedure} -setup {
+ destroy .mb
+} -body {
+ catch {menubutton .mb -gorp foo}
+ winfo exists .mb
+} -result 0
-catch {destroy .mb}
+
+deleteWindows
menubutton .mb -text "Test Menu"
pack .mb
-test menubutton-3.1 {MenuButtonWidgetCmd procedure} {
- list [catch {.mb} msg] $msg
-} {1 {wrong # args: should be ".mb option ?arg arg ...?"}}
-test menubutton-3.2 {ButtonWidgetCmd procedure, "cget" option} {
- list [catch {.mb c} msg] $msg
-} {1 {ambiguous option "c": must be cget or configure}}
-test menubutton-3.3 {ButtonWidgetCmd procedure, "cget" option} {
- list [catch {.mb cget} msg] $msg
-} {1 {wrong # args: should be ".mb cget option"}}
-test menubutton-3.4 {ButtonWidgetCmd procedure, "cget" option} {
- list [catch {.mb cget a b} msg] $msg
-} {1 {wrong # args: should be ".mb cget option"}}
-test menubutton-3.5 {ButtonWidgetCmd procedure, "cget" option} {
- list [catch {.mb cget -gorp} msg] $msg
-} {1 {unknown option "-gorp"}}
-test menubutton-3.6 {ButtonWidgetCmd procedure, "cget" option} {
+test menubutton-3.1 {MenuButtonWidgetCmd procedure} -body {
+ .mb
+} -returnCodes error -result {wrong # args: should be ".mb option ?arg ...?"}
+test menubutton-3.2 {ButtonWidgetCmd procedure, "cget" option} -body {
+ .mb c
+} -returnCodes error -result {ambiguous option "c": must be cget or configure}
+test menubutton-3.3 {ButtonWidgetCmd procedure, "cget" option} -body {
+ .mb cget
+} -returnCodes error -result {wrong # args: should be ".mb cget option"}
+test menubutton-3.4 {ButtonWidgetCmd procedure, "cget" option} -body {
+ .mb cget a b
+} -returnCodes error -result {wrong # args: should be ".mb cget option"}
+test menubutton-3.5 {ButtonWidgetCmd procedure, "cget" option} -body {
+ .mb cget -gorp
+} -returnCodes error -result {unknown option "-gorp"}
+test menubutton-3.6 {ButtonWidgetCmd procedure, "cget" option} -body {
.mb configure -highlightthickness 3
.mb cget -highlightthickness
-} {3}
-test menubutton-3.7 {ButtonWidgetCmd procedure, "configure" option} {
+} -result {3}
+test menubutton-3.7 {ButtonWidgetCmd procedure, "configure" option} -body {
llength [.mb configure]
-} {33}
-test menubutton-3.8 {ButtonWidgetCmd procedure, "configure" option} {
- list [catch {.mb configure -gorp} msg] $msg
-} {1 {unknown option "-gorp"}}
-test menubutton-3.9 {ButtonWidgetCmd procedure, "configure" option} {
- list [catch {.mb co -bg #ffffff -fg} msg] $msg
-} {1 {value for "-fg" missing}}
-test menubutton-3.10 {ButtonWidgetCmd procedure, "configure" option} {
+} -result {33}
+test menubutton-3.8 {ButtonWidgetCmd procedure, "configure" option} -body {
+ .mb configure -gorp
+} -returnCodes error -result {unknown option "-gorp"}
+test menubutton-3.9 {ButtonWidgetCmd procedure, "configure" option} -body {
+ .mb co -bg #ffffff -fg
+} -returnCodes error -result {value for "-fg" missing}
+test menubutton-3.10 {ButtonWidgetCmd procedure, "configure" option} -body {
.mb configure -fg #123456
.mb configure -bg #654321
lindex [.mb configure -fg] 4
-} {#123456}
-test menubutton-3.11 {ButtonWidgetCmd procedure, "configure" option} {
- list [catch {.mb foobar} msg] $msg
-} {1 {bad option "foobar": must be cget or configure}}
+} -result {#123456}
+test menubutton-3.11 {ButtonWidgetCmd procedure, "configure" option} -body {
+ .mb foobar
+} -returnCodes error -result {bad option "foobar": must be cget or configure}
+deleteWindows
# XXX Need to add tests for several procedures here. The tests for XXX
# XXX ConfigureMenuButton aren't complete either. XXX
-test menubutton-4.1 {ConfigureMenuButton procedure} {
- catch {destroy .mb1}
+test menubutton-4.1 {ConfigureMenuButton procedure} -setup {
+ deleteWindows
+} -body {
+ button .mb1 -text "Menubutton 1"
+ .mb1 configure -width 1i
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "1i"}
+test menubutton-4.2 {ConfigureMenuButton procedure} -setup {
+ deleteWindows
+} -body {
button .mb1 -text "Menubutton 1"
- list [catch {.mb1 configure -width 1i} msg] $msg $errorInfo
-} {1 {expected integer but got "1i"} {expected integer but got "1i"
+ catch {.mb1 configure -width 1i}
+ return $errorInfo
+} -cleanup {
+ deleteWindows
+} -result {expected integer but got "1i"
(processing -width option)
invoked from within
-".mb1 configure -width 1i"}}
-test menubutton-4.2 {ConfigureMenuButton procedure} {
- catch {destroy .mb1}
+".mb1 configure -width 1i"}
+
+test menubutton-4.3 {ConfigureMenuButton procedure} -setup {
+ deleteWindows
+} -body {
button .mb1 -text "Menubutton 1"
- list [catch {.mb1 configure -height 0.5c} msg] $msg $errorInfo
-} {1 {expected integer but got "0.5c"} {expected integer but got "0.5c"
+ .mb1 configure -height 0.5c
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "0.5c"}
+test menubutton-4.4 {ConfigureMenuButton procedure} -setup {
+ deleteWindows
+} -body {
+ button .mb1 -text "Menubutton 1"
+ catch {.mb1 configure -height 0.5c}
+ return $errorInfo
+} -cleanup {
+ deleteWindows
+} -result {expected integer but got "0.5c"
(processing -height option)
invoked from within
-".mb1 configure -height 0.5c"}}
-test menubutton-4.3 {ConfigureMenuButton procedure} {
- catch {destroy .mb1}
+".mb1 configure -height 0.5c"}
+
+test menubutton-4.5 {ConfigureMenuButton procedure} -setup {
+ deleteWindows
+} -body {
+ button .mb1 -bitmap questhead
+ .mb1 configure -width abc
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {bad screen distance "abc"}
+test menubutton-4.6 {ConfigureMenuButton procedure} -setup {
+ deleteWindows
+} -body {
button .mb1 -bitmap questhead
- list [catch {.mb1 configure -width abc} msg] $msg $errorInfo
-} {1 {bad screen distance "abc"} {bad screen distance "abc"
+ catch {.mb1 configure -width abc}
+ return $errorInfo
+} -cleanup {
+ deleteWindows
+} -result {bad screen distance "abc"
(processing -width option)
invoked from within
-".mb1 configure -width abc"}}
-test menubutton-4.4 {ConfigureMenuButton procedure} testImageType {
- catch {destroy .mb1}
- eval image delete [image names]
+".mb1 configure -width abc"}
+
+test menubutton-4.7 {ConfigureMenuButton procedure} -constraints {
+ testImageType
+} -setup {
+ deleteWindows
+ imageCleanup
+} -body {
image create test image1
button .mb1 -image image1
- list [catch {.mb1 configure -height 0.5x} msg] $msg $errorInfo
-} {1 {bad screen distance "0.5x"} {bad screen distance "0.5x"
+ .mb1 configure -height 0.5x
+} -cleanup {
+ deleteWindows
+ imageCleanup
+} -returnCodes error -result {bad screen distance "0.5x"}
+test menubutton-4.8 {ConfigureMenuButton procedure} -constraints {
+ testImageType
+} -setup {
+ deleteWindows
+ imageCleanup
+} -body {
+ image create test image1
+ button .mb1 -image image1
+ catch {.mb1 configure -height 0.5x}
+ return $errorInfo
+} -cleanup {
+ deleteWindows
+ imageCleanup
+} -result {bad screen distance "0.5x"
(processing -height option)
invoked from within
-".mb1 configure -height 0.5x"}}
-test menubutton-4.5 {ConfigureMenuButton procedure} {nonPortable fonts} {
- catch {destroy .mb1}
+".mb1 configure -height 0.5x"}
+
+test menubutton-4.9 {ConfigureMenuButton procedure} -constraints {
+ nonPortable fonts
+} -setup {
+ deleteWindows
+} -body {
button .mb1 -text "Sample text" -width 10 -height 2
pack .mb1
set result "[winfo reqwidth .mb1] [winfo reqheight .mb1]"
.mb1 configure -bitmap questhead
lappend result [winfo reqwidth .mb1] [winfo reqheight .mb1]
-} {102 46 20 12}
-test menubutton-4.6 {ConfigureMenuButton procedure - bad direction} {
- catch {destroy .mb}
+} -cleanup {
+ deleteWindows
+} -result {102 46 20 12}
+
+test menubutton-4.10 {ConfigureMenuButton procedure - bad direction} -setup {
+ deleteWindows
+} -body {
+ menubutton .mb -text "Test"
+ .mb configure -direction badValue
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {bad direction "badValue": must be above, below, flush, left, or right}
+test menubutton-4.11 {ConfigureMenuButton procedure - bad direction} -setup {
+ deleteWindows
+} -body {
menubutton .mb -text "Test"
- list [catch {.mb configure -direction badValue} msg] $msg \
- [.mb cget -direction] [destroy .mb]
-} {1 {bad direction "badValue": must be above, below, flush, left, or right} below {}}
+ catch {.mb configure -direction badValue}
+ list [.mb cget -direction] [destroy .mb]
+} -cleanup {
+ deleteWindows
+} -result {below {}}
+
+
# XXX Need to add tests for several procedures here. XXX
-test menubutton-5.1 {MenuButtonEventProc procedure} {
+test menubutton-5.1 {MenuButtonEventProc procedure} -setup {
deleteWindows
+ set x {}
+} -body {
menubutton .mb1 -bg #543210
rename .mb1 .mb2
- set x {}
lappend x [winfo children .]
lappend x [.mb2 cget -bg]
destroy .mb1
lappend x [info command .mb*] [winfo children .]
-} {.mb1 #543210 {} {}}
+} -cleanup {
+ deleteWindows
+} -result {.mb1 #543210 {} {}}
+
-test menubutton-6.1 {MenuButtonCmdDeletedProc procedure} {
+test menubutton-6.1 {MenuButtonCmdDeletedProc procedure} -setup {
deleteWindows
+} -body {
menubutton .mb1
rename .mb1 {}
list [info command .mb*] [winfo children .]
-} {{} {}}
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
-test menubutton-7.1 {ComputeMenuButtonGeometry procedure} testImageType {
- catch {destroy .mb}
+
+test menubutton-7.1 {ComputeMenuButtonGeometry procedure} -constraints {
+ testImageType
+} -setup {
+ deleteWindows
+ image create test image1
+} -body {
menubutton .mb -image image1 -bd 4 -highlightthickness 0
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
-} {38 23}
-test menubutton-7.2 {ComputeMenuButtonGeometry procedure} testImageType {
- catch {destroy .mb}
+} -cleanup {
+ deleteWindows
+ imageCleanup
+} -result {38 23}
+test menubutton-7.2 {ComputeMenuButtonGeometry procedure} -constraints {
+ testImageType
+} -setup {
+ deleteWindows
+ image create test image1
+} -body {
menubutton .mb -image image1 -bd 1 -highlightthickness 2
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
-} {36 21}
-test menubutton-7.3 {ComputeMenuButtonGeometry procedure} testImageType {
- catch {destroy .mb}
+} -cleanup {
+ deleteWindows
+ imageCleanup
+} -result {36 21}
+test menubutton-7.3 {ComputeMenuButtonGeometry procedure} -constraints {
+ testImageType
+} -setup {
+ deleteWindows
+ image create test image1
+} -body {
menubutton .mb -image image1 -bd 0 -highlightthickness 2 -padx 5 -pady 5
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
-} {34 19}
-test menubutton-7.4 {ComputeMenuButtonGeometry procedure} testImageType {
- catch {destroy .mb}
+} -cleanup {
+ deleteWindows
+ imageCleanup
+} -result {34 19}
+test menubutton-7.4 {ComputeMenuButtonGeometry procedure} -constraints {
+ testImageType
+} -setup {
+ deleteWindows
+ image create test image1
+} -body {
menubutton .mb -image image1 -bd 2 -relief raised -width 40 \
- -highlightthickness 2
+ -highlightthickness 2
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
-} {48 23}
-test menubutton-7.5 {ComputeMenuButtonGeometry procedure} testImageType {
- catch {destroy .mb}
+} -cleanup {
+ deleteWindows
+ imageCleanup
+} -result {48 23}
+test menubutton-7.5 {ComputeMenuButtonGeometry procedure} -constraints {
+ testImageType
+} -setup {
+ deleteWindows
+ image create test image1
+} -body {
menubutton .mb -image image1 -bd 2 -relief raised -height 30 \
- -highlightthickness 2
+ -highlightthickness 2
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
-} {38 38}
-test menubutton-7.6 {ComputeMenuButtonGeometry procedure} {
- catch {destroy .mb}
+} -cleanup {
+ deleteWindows
+ imageCleanup
+} -result {38 38}
+test menubutton-7.6 {ComputeMenuButtonGeometry procedure} -setup {
+ deleteWindows
+} -body {
menubutton .mb -bitmap question -bd 2 -relief raised \
- -highlightthickness 2
+ -highlightthickness 2
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
-} {25 35}
-test menubutton-7.7 {ComputeMenuButtonGeometry procedure} {
- catch {destroy .mb}
+} -cleanup {
+ deleteWindows
+} -result {25 35}
+test menubutton-7.7 {ComputeMenuButtonGeometry procedure} -setup {
+ deleteWindows
+} -body {
menubutton .mb -bitmap question -bd 2 -relief raised -width 40 \
- -highlightthickness 1
+ -highlightthickness 1
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
-} {46 33}
-test menubutton-7.8 {ComputeMenuButtonGeometry procedure} {
- catch {destroy .mb}
+} -cleanup {
+ deleteWindows
+} -result {46 33}
+test menubutton-7.8 {ComputeMenuButtonGeometry procedure} -setup {
+ deleteWindows
+} -body {
menubutton .mb -bitmap question -bd 2 -relief raised -height 50 \
- -highlightthickness 1
+ -highlightthickness 1
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
-} {23 56}
-test menubutton-7.9 {ComputeMenuButtonGeometry procedure} {fonts} {
- catch {destroy .mb}
+} -cleanup {
+ deleteWindows
+} -result {23 56}
+test menubutton-7.9 {ComputeMenuButtonGeometry procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
menubutton .mb -text String -bd 2 -relief raised -padx 0 -pady 0 \
- -highlightthickness 1
+ -highlightthickness 1
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
-} {42 20}
-test menubutton-7.10 {ComputeMenuButtonGeometry procedure} {fonts} {
- catch {destroy .mb}
+} -cleanup {
+ deleteWindows
+} -result {42 20}
+test menubutton-7.10 {ComputeMenuButtonGeometry procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
menubutton .mb -text String -bd 2 -relief raised -width 20 \
- -padx 0 -pady 0 -highlightthickness 1
+ -padx 0 -pady 0 -highlightthickness 1
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
-} {146 20}
-test menubutton-7.11 {ComputeMenuButtonGeometry procedure} {fonts} {
- catch {destroy .mb}
+} -cleanup {
+ deleteWindows
+} -result {146 20}
+test menubutton-7.11 {ComputeMenuButtonGeometry procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
menubutton .mb -text String -bd 2 -relief raised -height 2 \
- -padx 0 -pady 0 -highlightthickness 1
+ -padx 0 -pady 0 -highlightthickness 1
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
-} {42 34}
-test menubutton-7.12 {ComputeMenuButtonGeometry procedure} {fonts} {
- catch {destroy .mb}
+} -cleanup {
+ deleteWindows
+} -result {42 34}
+test menubutton-7.12 {ComputeMenuButtonGeometry procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
menubutton .mb -text String -bd 2 -relief raised -padx 10 -pady 5 \
- -highlightthickness 1
+ -highlightthickness 1
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
-} {62 30}
-test menubutton-7.13 {ComputeMenuButtonGeometry procedure} {nonPortable fonts} {
- catch {destroy .mb}
+} -cleanup {
+ deleteWindows
+} -result {62 30}
+test menubutton-7.13 {ComputeMenuButtonGeometry procedure} -constraints {
+ nonPortable fonts
+} -setup {
+ deleteWindows
+} -body {
menubutton .mb -text String -bd 2 -relief raised \
- -highlightthickness 1 -indicatoron 1
+ -highlightthickness 1 -indicatoron 1
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
-} {78 28}
-test menubutton-7.14 {ComputeMenuButtonGeometry procedure} {testImageType unix nonPortable} {
+} -cleanup {
+ deleteWindows
+} -result {78 28}
+test menubutton-7.14 {ComputeMenuButtonGeometry procedure} -constraints {
+ testImageType unix nonPortable
+} -setup {
+ deleteWindows
+ image create test image1
+} -body {
# The following test is non-portable because the indicator's pixel
# size varies to maintain constant absolute size.
- catch {destroy .mb}
menubutton .mb -image image1 -bd 2 -relief raised \
- -highlightthickness 2 -indicatoron 1
+ -highlightthickness 2 -indicatoron 1
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
-} {64 23}
-test menubutton-7.15 {ComputeMenuButtonGeometry procedure} {testImageType win nonPortable} {
+} -cleanup {
+ deleteWindows
+ imageCleanup
+} -result {64 23}
+test menubutton-7.15 {ComputeMenuButtonGeometry procedure} -constraints {
+ testImageType win nonPortable
+} -setup {
+ deleteWindows
+ image create test image1
+} -body {
# The following test is non-portable because the indicator's pixel
# size varies to maintain constant absolute size.
- catch {destroy .mb}
menubutton .mb -image image1 -bd 2 -relief raised \
- -highlightthickness 2 -indicatoron 1
+ -highlightthickness 2 -indicatoron 1
pack .mb
list [winfo reqwidth .mb] [winfo reqheight .mb]
-} {65 23}
+} -cleanup {
+ deleteWindows
+ imageCleanup
+} -result {65 23}
-set l [interp hidden]
-deleteWindows
-test menubutton-8.1 {menubutton vs hidden commands} {
- catch {destroy .mb}
+test menubutton-8.1 {menubutton vs hidden commands} -body {
+ set l [interp hidden]
+ deleteWindows
menubutton .mb
interp hide {} .mb
destroy .mb
- list [winfo children .] [interp hidden]
-} [list {} $l]
+ set res1 [list [winfo children .] [interp hidden]]
+ set res2 [list {} $l]
+ expr {$res1 eq $res2}
+} -result 1
+
+
-eval image delete [image names]
deleteWindows
option clear
+imageFinish
# cleanup
cleanupTests
return
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tests/message.test b/tests/message.test
index 93344c4..dcffc72 100644
--- a/tests/message.test
+++ b/tests/message.test
@@ -6,115 +6,469 @@
# Copyright (c) 1998-2000 by Ajuba Solutions.
# All rights reserved.
-package require tcltest 2.1
-eval tcltest::configure $argv
+package require tcltest 2.2
+namespace import ::tcltest::*
tcltest::loadTestedCommands
+eval tcltest::configure $argv
+
+
+test message-1.1 {configuration option: "anchor"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -anchor w
+ .m cget -anchor
+} -cleanup {
+ destroy .m
+} -result {w}
+test message-1.2 {configuration option: "anchor"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -anchor bogus
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}
+
+test message-1.3 {configuration option: "aspect"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -aspect 3
+ .m cget -aspect
+} -cleanup {
+ destroy .m
+} -result {3}
+test message-1.4 {configuration option: "aspect"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -aspect bogus
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {expected integer but got "bogus"}
+
+test message-1.5 {configuration option: "background"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -background #ff0000
+ .m cget -background
+} -cleanup {
+ destroy .m
+} -result {#ff0000}
+test message-1.6 {configuration option: "background"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -background non-existent
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test message-1.7 {configuration option: "bd"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -bd 4
+ .m cget -bd
+} -cleanup {
+ destroy .m
+} -result {4}
+test message-1.8 {configuration option: "bd"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -bd badValue
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+test message-1.9 {configuration option: "bg"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -bg #ff0000
+ .m cget -bg
+} -cleanup {
+ destroy .m
+} -result {#ff0000}
+test message-1.10 {configuration option: "bg"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -bg non-existent
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test message-1.11 {configuration option: "borderwidth"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -borderwidth 1.3
+ .m cget -borderwidth
+} -cleanup {
+ destroy .m
+} -result {1}
+test message-1.12 {configuration option: "borderwidth"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -borderwidth badValue
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+test message-1.13 {configuration option: "cursor"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -cursor arrow
+ .m cget -cursor
+} -cleanup {
+ destroy .m
+} -result {arrow}
+test message-1.14 {configuration option: "cursor"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -cursor badValue
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {bad cursor spec "badValue"}
+
+test message-1.15 {configuration option: "fg"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -fg #00ff00
+ .m cget -fg
+} -cleanup {
+ destroy .m
+} -result {#00ff00}
+test message-1.16 {configuration option: "fg"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -fg badValue
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {unknown color name "badValue"}
+
+test message-1.17 {configuration option: "font"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -font fixed
+ .m cget -font
+} -cleanup {
+ destroy .m
+} -result {fixed}
+test message-1.18 {configuration option: "font"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -font {}
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {font "" doesn't exist}
+
+test message-1.19 {configuration option: "-foreground"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -foreground green
+ .m cget -foreground
+} -cleanup {
+ destroy .m
+} -result {green}
+test message-1.20 {configuration option: "-foreground"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -foreground badValue
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {unknown color name "badValue"}
-option add *Message.borderWidth 2
-option add *Message.highlightThickness 2
-option add *Message.font {Helvetica -12 bold}
-
-message .m
-pack .m
-update
-set i 0
-foreach test {
- {-anchor w w bogus {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}}
- {-aspect 3 3 bogus {expected integer but got "bogus"}}
- {-background #ff0000 #ff0000 non-existent
- {unknown color name "non-existent"}}
- {-bd 4 4 badValue {bad screen distance "badValue"}}
- {-bg #ff0000 #ff0000 non-existent
- {unknown color name "non-existent"}}
- {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
- {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
- {-fg #00ff00 #00ff00 badValue {unknown color name "badValue"}}
- {-font fixed fixed {} {font "" doesn't exist}}
- {-foreground green green badValue {unknown color name "badValue"}}
- {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}}
- {-highlightcolor #123456 #123456 non-existent
- {unknown color name "non-existent"}}
- {-highlightthickness 2 2 badValue {bad screen distance "badValue"}}
- {-justify right right bogus {bad justification "bogus": must be left, right, or center}}
- {-padx 12m 12m 420x {bad screen distance "420x"}}
- {-pady 12m 12m 420x {bad screen distance "420x"}}
- {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
- {-text "Sample text" {Sample text} {} {} {1 1 1 1}}
- {-textvariable i i {} {} {1 1 1 1}}
- {-width 32 32 badValue {bad screen distance "badValue"}}
-} {
- set name [lindex $test 0]
- test message-1.$i {configuration options} {
- .m configure $name [lindex $test 1]
- lindex [.m configure $name] 4
- } [lindex $test 2]
- incr i
- if {[lindex $test 3] != ""} {
- test message-1.$i {configuration options} {
- list [catch {.m configure $name [lindex $test 3]} msg] $msg
- } [list 1 [lindex $test 4]]
- }
- .m configure $name [lindex [.m configure $name] 3]
- incr i
-}
-destroy .m
-
-test message-2.1 {Tk_MessageObjCmd procedure} {
- list [catch {message} msg] $msg
-} {1 {wrong # args: should be "message pathName ?options?"}}
-test message-2.2 {Tk_MessageObjCmd procedure} {
- list [catch {message foo} msg] $msg [winfo child .]
-} {1 {bad window path name "foo"} {}}
-test message-2.3 {Tk_MessageObjCmd procedure} {
- list [catch {message .s -gorp dumb} msg] $msg [winfo child .]
-} {1 {unknown option "-gorp"} {}}
-
-test message-3.1 {MessageWidgetObjCmd procedure} {
+test message-1.21 {configuration option: "highlightbackground"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -highlightbackground #112233
+ .m cget -highlightbackground
+} -cleanup {
+ destroy .m
+} -result {#112233}
+test message-1.22 {configuration option: "highlightbackground"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -highlightbackground ugly
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {unknown color name "ugly"}
+
+test message-1.23 {configuration option: "highlightcolor"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -highlightcolor #123456
+ .m cget -highlightcolor
+} -cleanup {
+ destroy .m
+} -result {#123456}
+test message-1.24 {configuration option: "highlightcolor"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -highlightcolor non-existent
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test message-1.25 {configuration option: "highlightthickness"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -highlightthickness 2
+ .m cget -highlightthickness
+} -cleanup {
+ destroy .m
+} -result {2}
+test message-1.26 {configuration option: "highlightthickness"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -highlightthickness badValue
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+test message-1.27 {configuration option: "justify"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -justify right
+ .m cget -justify
+} -cleanup {
+ destroy .m
+} -result {right}
+test message-1.28 {configuration option: "justify"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -justify bogus
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {bad justification "bogus": must be left, right, or center}
+
+test message-1.29 {configuration option: "padx"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -padx 12m
+ .m cget -padx
+} -cleanup {
+ destroy .m
+} -result {12m}
+test message-1.30 {configuration option: "padx"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -padx 420x
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {bad screen distance "420x"}
+
+test message-1.31 {configuration option: "pady"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -pady 12m
+ .m cget -pady
+} -cleanup {
+ destroy .m
+} -result {12m}
+test message-1.32 {configuration option: "pady"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -pady 420x
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {bad screen distance "420x"}
+
+test message-1.33 {configuration option: "relief"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -relief ridge
+ .m cget -relief
+} -cleanup {
+ destroy .m
+} -result {ridge}
+test message-1.34 {configuration option: "relief"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -relief badValue
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}
+
+test message-1.35 {configuration options: "text"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -text "Sample text"
+ .m cget -text
+} -cleanup {
+ destroy .m
+} -result {Sample text}
+
+test message-1.36 {configuration option: "textvariable"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -textvariable i
+ .m cget -textvariable
+} -cleanup {
+ destroy .m
+} -result {i}
+
+test message-1.37 {configuration option: "width"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -width 2
+ .m cget -width
+} -cleanup {
+ destroy .m
+} -result {2}
+test message-1.38 {configuration option: "width"} -setup {
+ message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
+ pack .m
+ update
+} -body {
+ .m configure -width badValue
+} -cleanup {
+ destroy .m
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+
+test message-2.1 {Tk_MessageObjCmd procedure} -body {
+ message
+} -returnCodes {error} -result {wrong # args: should be "message pathName ?-option value ...?"}
+
+test message-2.2 {Tk_MessageObjCmd procedure} -body {
+ message foo
+} -returnCodes {error} -result {bad window path name "foo"}
+test message-2.3 {Tk_MessageObjCmd procedure} -body {
+ catch {message foo}
+ winfo child .
+} -result {}
+
+test message-2.4 {Tk_MessageObjCmd procedure} -body {
+ message .s -gorp dump
+} -returnCodes {error} -result {unknown option "-gorp"}
+test message-2.5 {Tk_MessageObjCmd procedure} -body {
+ catch {message .s -gorp dump}
+ winfo child .
+} -result {}
+
+
+test message-3.1 {MessageWidgetObjCmd procedure} -setup {
message .m
- set result [list [catch {.m} msg] $msg]
+} -body {
+ .m
+} -cleanup {
destroy .m
- set result
-} {1 {wrong # args: should be ".m option ?arg arg ...?"}}
-test message-3.2 {MessageWidgetObjCmd procedure, "cget"} {
+} -returnCodes error -result {wrong # args: should be ".m option ?arg ...?"}
+test message-3.2 {MessageWidgetObjCmd procedure, "cget"} -setup {
message .m
- set result [list [catch {.m cget} msg] $msg]
+} -body {
+ .m cget
+} -cleanup {
destroy .m
- set result
-} {1 {wrong # args: should be ".m cget option"}}
-test message-3.3 {MessageWidgetObjCmd procedure, "cget"} {
+} -returnCodes error -result {wrong # args: should be ".m cget option"}
+test message-3.3 {MessageWidgetObjCmd procedure, "cget"} -setup {
message .m
- set result [list [catch {.m cget -gorp} msg] $msg]
+} -body {
+ .m cget -gorp
+} -cleanup {
destroy .m
- set result
-} {1 {unknown option "-gorp"}}
-test message-3.4 {MessageWidgetObjCmd procedure, "cget"} {
+} -returnCodes error -result {unknown option "-gorp"}
+
+test message-3.4 {MessageWidgetObjCmd procedure, "configure"} -setup {
message .m
+} -body {
.m configure -text foobar
- set result [.m cget -text]
+ lindex [.m configure -text] 4
+} -cleanup {
destroy .m
- set result
-} "foobar"
-test message-3.5 {MessageWidgetObjCmd procedure, "configure"} {
+} -result {foobar}
+test message-3.5 {MessageWidgetObjCmd procedure, "configure"} -setup {
message .m
- set result [llength [.m configure]]
+} -body {
+ llength [.m configure]
+} -cleanup {
destroy .m
- set result
-} 21
-test message-3.6 {MessageWidgetObjCmd procedure, "configure"} {
+} -result {21}
+test message-3.6 {MessageWidgetObjCmd procedure, "configure"} -setup {
message .m
- set result [list [catch {.m configure -foo} msg] $msg]
+} -body {
+ .m configure -foo
+} -cleanup {
destroy .m
- set result
-} {1 {unknown option "-foo"}}
-test message-3.7 {MessageWidgetObjCmd procedure, "configure"} {
+} -returnCodes error -result {unknown option "-foo"}
+test message-3.7 {MessageWidgetObjCmd procedure, "configure"} -setup {
message .m
+} -body {
.m configure -bd 4
.m configure -bg #ffffff
- set result [lindex [.m configure -bd] 4]
+ lindex [.m configure -bd] 4
+} -cleanup {
destroy .m
- set result
-} {4}
+} -result {4}
-# cleanup
cleanupTests
return
diff --git a/tests/msgbox.test b/tests/msgbox.test
index ec98c89..643ae2c 100644
--- a/tests/msgbox.test
+++ b/tests/msgbox.test
@@ -5,65 +5,79 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
+namespace import -force tcltest::test
-test msgbox-1.1 {tk_messageBox command} {
- list [catch {tk_messageBox -foo} msg] $msg
-} {1 {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}}
-test msgbox-1.2 {tk_messageBox command} {
- list [catch {tk_messageBox -foo bar} msg] $msg
-} {1 {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}}
-
-catch {tk_messageBox -foo bar} msg
-regsub -all , $msg "" options
-regsub \"-foo\" $options "" options
-
-foreach option $options {
- if {[string index $option 0] eq "-"} {
- test msgbox-1.3$option {tk_messageBox command} -body {
- tk_messageBox $option
- } -returnCodes error -result "value for \"$option\" missing"
- }
-}
-test msgbox-1.4 {tk_messageBox command} {
- list [catch {tk_messageBox -default} msg] $msg
-} {1 {value for "-default" missing}}
+test msgbox-1.1 {tk_messageBox command} -body {
+ tk_messageBox -foo
+} -returnCodes error -result {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}
+test msgbox-1.2 {tk_messageBox command} -body {
+ tk_messageBox -foo bar
+} -returnCodes error -result {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}
-test msgbox-1.5 {tk_messageBox command} {
- list [catch {tk_messageBox -type foo} msg] $msg
-} {1 {bad -type value "foo": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel}}
+test msgbox-1.3 {tk_messageBox command} -body {
+ tk_messageBox -default
+} -returnCodes error -result {value for "-default" missing}
+test msgbox-1.4 {tk_messageBox command} -body {
+ tk_messageBox -detail
+} -returnCodes error -result {value for "-detail" missing}
+test msgbox-1.5 {tk_messageBox command} -body {
+ tk_messageBox -icon
+} -returnCodes error -result {value for "-icon" missing}
+test msgbox-1.6 {tk_messageBox command} -body {
+ tk_messageBox -message
+} -returnCodes error -result {value for "-message" missing}
+test msgbox-1.7 {tk_messageBox command} -body {
+ tk_messageBox -parent
+} -returnCodes error -result {value for "-parent" missing}
+test msgbox-1.8 {tk_messageBox command} -body {
+ tk_messageBox -title
+} -returnCodes error -result {value for "-title" missing}
+test msgbox-1.9 {tk_messageBox command} -body {
+ tk_messageBox -type
+} -returnCodes error -result {value for "-type" missing}
-proc createPlatformMsg {val} {
- global tcl_platform
- if {$tcl_platform(platform) == "unix"} {
- return "invalid default button \"$val\""
- }
- return "bad -default value \"$val\": must be abort, retry, ignore, ok, cancel, no, or yes"
-}
+test msgbox-1.10 {tk_messageBox command} -body {
+ tk_messageBox -default
+} -returnCodes error -result {value for "-default" missing}
+
+test msgbox-1.11 {tk_messageBox command} -body {
+ tk_messageBox -type foo
+} -returnCodes error -result {bad -type value "foo": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel}
-test msgbox-1.6 {tk_messageBox command} {
- list [catch {tk_messageBox -default 1.1} msg] $msg
-} [list 1 [createPlatformMsg "1.1"]]
+test msgbox-1.12 {tk_messageBox command} -constraints unix -body {
+ tk_messageBox -default 1.1
+} -returnCodes error -result {invalid default button "1.1"}
+test msgbox-1.13 {tk_messageBox command} -constraints macOrWin -body {
+ tk_messageBox -default 1.1
+} -returnCodes error -result {bad -default value "1.1": must be abort, retry, ignore, ok, cancel, no, or yes}
-test msgbox-1.7 {tk_messageBox command} {
- list [catch {tk_messageBox -default foo} msg] $msg
-} [list 1 [createPlatformMsg "foo"]]
+test msgbox-1.14 {tk_messageBox command} -constraints unix -body {
+ tk_messageBox -default foo
+} -returnCodes error -result {invalid default button "foo"}
+test msgbox-1.15 {tk_messageBox command} -constraints macOrWin -body {
+ tk_messageBox -default foo
+} -returnCodes error -result {bad -default value "foo": must be abort, retry, ignore, ok, cancel, no, or yes}
-test msgbox-1.8 {tk_messageBox command} {
- list [catch {tk_messageBox -type yesno -default 3} msg] $msg
-} [list 1 [createPlatformMsg "3"]]
+test msgbox-1.16 {tk_messageBox command} -constraints unix -body {
+ tk_messageBox -type yesno -default 3
+} -returnCodes error -result {invalid default button "3"}
+test msgbox-1.17 {tk_messageBox command} -constraints macOrWin -body {
+ tk_messageBox -type yesno -default 3
+} -returnCodes error -result {bad -default value "3": must be abort, retry, ignore, ok, cancel, no, or yes}
-test msgbox-1.9 {tk_messageBox command} {
- list [catch {tk_messageBox -icon foo} msg] $msg
-} {1 {bad -icon value "foo": must be error, info, question, or warning}}
+test msgbox-1.18 {tk_messageBox command} -body {
+ tk_messageBox -icon foo
+} -returnCodes error -result {bad -icon value "foo": must be error, info, question, or warning}
+test msgbox-1.19 {tk_messageBox command} -body {
+ tk_messageBox -parent foo.bar
+} -returnCodes error -result {bad window path name "foo.bar"}
-test msgbox-1.10 {tk_messageBox command} {
- list [catch {tk_messageBox -parent foo.bar} msg] $msg
-} {1 {bad window path name "foo.bar"}}
+catch {tk_messageBox -foo bar}
set isNative [expr {[info commands tk::MessageBox] == ""}]
proc ChooseMsg {parent btn} {
@@ -104,72 +118,332 @@ proc SendEventToMsg {parent btn type} {
event generate $w <KeyPress> -keysym Return
}
}
-
-set parent .
-
-set specs {
- {"abortretryignore" MB_ABORTRETRYIGNORE 3 {"abort" "retry" "ignore"}}
- {"ok" MB_OK 1 {"ok" }}
- {"okcancel" MB_OKCANCEL 2 {"ok" "cancel" }}
- {"retrycancel" MB_RETRYCANCEL 2 {"retry" "cancel" }}
- {"yesno" MB_YESNO 2 {"yes" "no" }}
- {"yesnocancel" MB_YESNOCANCEL 3 {"yes" "no" "cancel"}}
-}
-
#
# Try out all combinations of (type) x (default button) and
# (type) x (icon).
#
-set count 1
-foreach spec $specs {
- set type [lindex $spec 0]
- set buttons [lindex $spec 3]
-
- set button [lindex $buttons 0]
- test msgbox-2.$count {tk_messageBox command} nonUnixUserInteraction {
- ChooseMsg $parent $button
- tk_messageBox -title Hi -message "Please press $button" \
- -type $type
- } $button
- incr count
-
- foreach icon {warning error info question} {
- test msgbox-2.$count {tk_messageBox command -icon option} \
- nonUnixUserInteraction {
- ChooseMsg $parent $button
- tk_messageBox -title Hi -message "Please press $button" \
- -type $type -icon $icon
- } $button
- incr count
- }
+test msgbox-2.1 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . abort
+ tk_messageBox -title Hi -message "Please press abort" -type abortretryignore
+} -result {abort}
+test msgbox-2.2 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . abort
+ tk_messageBox -title Hi -message "Please press abort" \
+ -type abortretryignore -icon warning
+} -result {abort}
+test msgbox-2.3 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . abort
+ tk_messageBox -title Hi -message "Please press abort" \
+ -type abortretryignore -icon error
+} -result {abort}
+test msgbox-2.4 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . abort
+ tk_messageBox -title Hi -message "Please press abort" \
+ -type abortretryignore -icon info
+} -result {abort}
+test msgbox-2.5 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . abort
+ tk_messageBox -title Hi -message "Please press abort" \
+ -type abortretryignore -icon question
+} -result {abort}
+test msgbox-2.6 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . abort
+ tk_messageBox -title Hi -message "Please press abort" \
+ -type abortretryignore -default abort
+} -result {abort}
+test msgbox-2.7 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . retry
+ tk_messageBox -title Hi -message "Please press retry" \
+ -type abortretryignore -default retry
+} -result {retry}
+test msgbox-2.8 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ignore
+ tk_messageBox -title Hi -message "Please press ignore" \
+ -type abortretryignore -default ignore
+} -result {ignore}
+test msgbox-2.9 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" -type ok
+} -result {ok}
+test msgbox-2.10 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type ok -icon warning
+} -result {ok}
+test msgbox-2.11 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type ok -icon error
+} -result {ok}
+test msgbox-2.12 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type ok -icon info
+} -result {ok}
+test msgbox-2.13 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type ok -icon question
+} -result {ok}
+test msgbox-2.14 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type ok -default ok
+} -result {ok}
+test msgbox-2.15 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" -type okcancel
+} -result {ok}
+test msgbox-2.16 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type okcancel -icon warning
+} -result {ok}
+test msgbox-2.17 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type okcancel -icon error
+} -result {ok}
+test msgbox-2.18 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type okcancel -icon info
+} -result {ok}
+test msgbox-2.19 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type okcancel -icon question
+} -result {ok}
+test msgbox-2.20 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type okcancel -default ok
+} -result {ok}
+test msgbox-2.21 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . cancel
+ tk_messageBox -title Hi -message "Please press cancel" \
+ -type okcancel -default cancel
+} -result {cancel}
+test msgbox-2.22 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . retry
+ tk_messageBox -title Hi -message "Please press retry" -type retrycancel
+} -result {retry}
+test msgbox-2.23 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . retry
+ tk_messageBox -title Hi -message "Please press retry" \
+ -type retrycancel -icon warning
+} -result {retry}
+test msgbox-2.24 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . retry
+ tk_messageBox -title Hi -message "Please press retry" \
+ -type retrycancel -icon error
+} -result {retry}
+test msgbox-2.25 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . retry
+ tk_messageBox -title Hi -message "Please press retry" \
+ -type retrycancel -icon info
+} -result {retry}
+test msgbox-2.26 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . retry
+ tk_messageBox -title Hi -message "Please press retry" \
+ -type retrycancel -icon question
+} -result {retry}
+test msgbox-2.27 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . retry
+ tk_messageBox -title Hi -message "Please press retry" \
+ -type retrycancel -default retry
+} -result {retry}
+test msgbox-2.28 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . cancel
+ tk_messageBox -title Hi -message "Please press cancel" \
+ -type retrycancel -default cancel
+} -result {cancel}
+test msgbox-2.29 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" -type yesno
+} -result {yes}
+test msgbox-2.30 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesno -icon warning
+} -result {yes}
+test msgbox-2.31 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesno -icon error
+} -result {yes}
+test msgbox-2.32 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesno -icon info
+} -result {yes}
+test msgbox-2.33 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesno -icon question
+} -result {yes}
+test msgbox-2.34 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesno -default yes
+} -result {yes}
+test msgbox-2.35 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . no
+ tk_messageBox -title Hi -message "Please press no" \
+ -type yesno -default no
+} -result {no}
+test msgbox-2.36 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" -type yesnocancel
+} -result {yes}
+test msgbox-2.37 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesnocancel -icon warning
+} -result {yes}
+test msgbox-2.38 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesnocancel -icon error
+} -result {yes}
+test msgbox-2.39 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesnocancel -icon info
+} -result {yes}
+test msgbox-2.40 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesnocancel -icon question
+} -result {yes}
+test msgbox-2.41 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesnocancel -default yes
+} -result {yes}
+test msgbox-2.42 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . no
+ tk_messageBox -title Hi -message "Please press no" \
+ -type yesnocancel -default no
+} -result {no}
+test msgbox-2.43 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . cancel
+ tk_messageBox -title Hi -message "Please press cancel" \
+ -type yesnocancel -default cancel
+} -result {cancel}
- foreach button $buttons {
- test msgbox-2.$count {tk_messageBox command} nonUnixUserInteraction {
- ChooseMsg $parent $button
- tk_messageBox -title Hi -message "Please press $button" \
- -type $type -default $button
- } "$button"
- incr count
- }
-}
# These tests will hang your test suite if they fail.
-test msgbox-3.1 {tk_messageBox handles withdrawn parent} nonUnixUserInteraction {
+test msgbox-3.1 {tk_messageBox handles withdrawn parent} -constraints {
+ nonUnixUserInteraction
+} -body {
wm withdraw .
ChooseMsg . "ok"
tk_messageBox -title Hi -message "Please press ok" \
-type ok -default ok
-} "ok"
-wm deiconify .
+} -cleanup {
+ wm deiconify .
+} -result {ok}
-test msgbox-3.2 {tk_messageBox handles iconified parent} nonUnixUserInteraction {
+test msgbox-3.2 {tk_messageBox handles iconified parent} -constraints {
+ nonUnixUserInteraction
+} -body {
wm iconify .
ChooseMsg . "ok"
tk_messageBox -title Hi -message "Please press ok" \
-type ok -default ok
-} "ok"
-wm deiconify .
+} -cleanup {
+ wm deiconify .
+} -result {ok}
# cleanup
cleanupTests
return
+
+
diff --git a/tests/obj.test b/tests/obj.test
index 25bd70f..eece58e 100644
--- a/tests/obj.test
+++ b/tests/obj.test
@@ -5,26 +5,24 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
-test obj-1.1 {TkGetPixelsFromObj} {
-} {}
+test obj-1.1 {TkGetPixelsFromObj} -body {
+} -result {}
-test obj-2.1 {FreePixelInternalRep} {
-} {}
+test obj-2.1 {FreePixelInternalRep} -body {
+} -result {}
-test obj-3.1 {DupPixelInternalRep} {
-} {}
+test obj-3.1 {DupPixelInternalRep} -body {
+} -result {}
-test obj-4.1 {SetPixelFromAny} {
-} {}
+test obj-4.1 {SetPixelFromAny} -body {
+} -result {}
-
-deleteWindows
-
# cleanup
cleanupTests
return
diff --git a/tests/oldpack.test b/tests/oldpack.test
index 2f9b979..72ec065 100644
--- a/tests/oldpack.test
+++ b/tests/oldpack.test
@@ -7,13 +7,14 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
+namespace import -force tcltest::test
# First, test a single window packed in various ways in a parent
-catch {destroy .pack}
+destroy .pack
frame .pack
place .pack -width 100 -height 100
frame .pack.red -width 10 -height 20
@@ -29,189 +30,189 @@ frame .pack.violet -width 80 -height 20
label .pack.violet.l -text P -bd 2 -relief raised
place .pack.violet.l -relwidth 1.0 -relheight 1.0
-test oldpack-1.1 {basic positioning} {
+test oldpack-1.1 {basic positioning} -body {
pack ap .pack .pack.red top
update
winfo geometry .pack.red
-} 10x20+45+0
-test oldpack-1.2 {basic positioning} {
+} -result 10x20+45+0
+test oldpack-1.2 {basic positioning} -body {
pack append .pack .pack.red bottom
update
winfo geometry .pack.red
-} 10x20+45+80
-test oldpack-1.3 {basic positioning} {
+} -result 10x20+45+80
+test oldpack-1.3 {basic positioning} -body {
pack append .pack .pack.red left
update
winfo geometry .pack.red
-} 10x20+0+40
-test oldpack-1.4 {basic positioning} {
+} -result 10x20+0+40
+test oldpack-1.4 {basic positioning} -body {
pack append .pack .pack.red right
update
winfo geometry .pack.red
-} 10x20+90+40
+} -result 10x20+90+40
# Try adding padding around the window and make sure that the
# window gets a larger frame.
-test oldpack-2.1 {padding} {
+test oldpack-2.1 {padding} -body {
pack append .pack .pack.red {t padx 20}
update
winfo geometry .pack.red
-} 10x20+45+0
-test oldpack-2.2 {padding} {
+} -result 10x20+45+0
+test oldpack-2.2 {padding} -body {
pack append .pack .pack.red {top pady 20}
update
winfo geometry .pack.red
-} 10x20+45+10
-test oldpack-2.3 {padding} {
+} -result 10x20+45+10
+test oldpack-2.3 {padding} -body {
pack append .pack .pack.red {l padx 20}
update
winfo geometry .pack.red
-} 10x20+10+40
-test oldpack-2.4 {padding} {
+} -result 10x20+10+40
+test oldpack-2.4 {padding} -body {
pack append .pack .pack.red {left pady 20}
update
winfo geometry .pack.red
-} 10x20+0+40
+} -result 10x20+0+40
# Position the window at different positions in its frame to
# make sure they all work. Try two differenet frame locations,
# to make sure that frame offsets are being added in correctly.
-test oldpack-3.1 {framing} {
+test oldpack-3.1 {framing} -body {
pack append .pack .pack.red {b padx 20 pady 30}
update
winfo geometry .pack.red
-} 10x20+45+65
-test oldpack-3.2 {framing} {
+} -result 10x20+45+65
+test oldpack-3.2 {framing} -body {
pack append .pack .pack.red {bottom padx 20 pady 30 fr n}
update
winfo geometry .pack.red
-} 10x20+45+50
-test oldpack-3.3 {framing} {
+} -result 10x20+45+50
+test oldpack-3.3 {framing} -body {
pack append .pack .pack.red {bottom padx 20 pady 30 frame ne}
update
winfo geometry .pack.red
-} 10x20+90+50
-test oldpack-3.4 {framing} {
+} -result 10x20+90+50
+test oldpack-3.4 {framing} -body {
pack append .pack .pack.red {bottom padx 20 pady 30 frame e}
update
winfo geometry .pack.red
-} 10x20+90+65
-test oldpack-3.5 {framing} {
+} -result 10x20+90+65
+test oldpack-3.5 {framing} -body {
pack append .pack .pack.red {bottom padx 20 pady 30 frame se}
update
winfo geometry .pack.red
-} 10x20+90+80
-test oldpack-3.6 {framing} {
+} -result 10x20+90+80
+test oldpack-3.6 {framing} -body {
pack append .pack .pack.red {bottom padx 20 pady 30 frame s}
update
winfo geometry .pack.red
-} 10x20+45+80
-test oldpack-3.7 {framing} {
+} -result 10x20+45+80
+test oldpack-3.7 {framing} -body {
pack append .pack .pack.red {bottom padx 20 pady 30 frame sw}
update
winfo geometry .pack.red
-} 10x20+0+80
-test oldpack-3.8 {framing} {
+} -result 10x20+0+80
+test oldpack-3.8 {framing} -body {
pack append .pack .pack.red {bottom padx 20 pady 30 frame w}
update
winfo geometry .pack.red
-} 10x20+0+65
-test oldpack-3.9 {framing} {
+} -result 10x20+0+65
+test oldpack-3.9 {framing} -body {
pack append .pack .pack.red {bottom padx 20 pady 30 frame nw}
update
winfo geometry .pack.red
-} 10x20+0+50
-test oldpack-3.10 {framing} {
+} -result 10x20+0+50
+test oldpack-3.10 {framing} -body {
pack append .pack .pack.red {bottom padx 20 pady 30 frame c}
update
winfo geometry .pack.red
-} 10x20+45+65
-test oldpack-3.11 {framing} {
+} -result 10x20+45+65
+test oldpack-3.11 {framing} -body {
pack append .pack .pack.red {r padx 20 pady 30}
update
winfo geometry .pack.red
-} 10x20+80+40
-test oldpack-3.12 {framing} {
+} -result 10x20+80+40
+test oldpack-3.12 {framing} -body {
pack append .pack .pack.red {right padx 20 pady 30 frame n}
update
winfo geometry .pack.red
-} 10x20+80+0
-test oldpack-3.13 {framing} {
+} -result 10x20+80+0
+test oldpack-3.13 {framing} -body {
pack append .pack .pack.red {right padx 20 pady 30 frame ne}
update
winfo geometry .pack.red
-} 10x20+90+0
-test oldpack-3.14 {framing} {
+} -result 10x20+90+0
+test oldpack-3.14 {framing} -body {
pack append .pack .pack.red {right padx 20 pady 30 frame e}
update
winfo geometry .pack.red
-} 10x20+90+40
-test oldpack-3.15 {framing} {
+} -result 10x20+90+40
+test oldpack-3.15 {framing} -body {
pack append .pack .pack.red {right padx 20 pady 30 frame se}
update
winfo geometry .pack.red
-} 10x20+90+80
-test oldpack-3.16 {framing} {
+} -result 10x20+90+80
+test oldpack-3.16 {framing} -body {
pack append .pack .pack.red {right padx 20 pady 30 frame s}
update
winfo geometry .pack.red
-} 10x20+80+80
-test oldpack-3.17 {framing} {
+} -result 10x20+80+80
+test oldpack-3.17 {framing} -body {
pack append .pack .pack.red {right padx 20 pady 30 frame sw}
update
winfo geometry .pack.red
-} 10x20+70+80
-test oldpack-3.18 {framing} {
+} -result 10x20+70+80
+test oldpack-3.18 {framing} -body {
pack append .pack .pack.red {right padx 20 pady 30 frame w}
update
winfo geometry .pack.red
-} 10x20+70+40
-test oldpack-3.19 {framing} {
+} -result 10x20+70+40
+test oldpack-3.19 {framing} -body {
pack append .pack .pack.red {right padx 20 pady 30 frame nw}
update
winfo geometry .pack.red
-} 10x20+70+0
-test oldpack-3.20 {framing} {
+} -result 10x20+70+0
+test oldpack-3.20 {framing} -body {
pack append .pack .pack.red {right padx 20 pady 30 frame center}
update
winfo geometry .pack.red
-} 10x20+80+40
+} -result 10x20+80+40
# Try out various filling combinations in a couple of different
# frame locations.
-test oldpack-4.1 {filling} {
+test oldpack-4.1 {filling} -body {
pack append .pack .pack.red {bottom padx 20 pady 30 fillx}
update
winfo geometry .pack.red
-} 100x20+0+65
-test oldpack-4.2 {filling} {
+} -result 100x20+0+65
+test oldpack-4.2 {filling} -body {
pack append .pack .pack.red {bottom padx 20 pady 30 filly}
update
winfo geometry .pack.red
-} 10x50+45+50
-test oldpack-4.3 {filling} {
+} -result 10x50+45+50
+test oldpack-4.3 {filling} -body {
pack append .pack .pack.red {bottom padx 20 pady 30 fill}
update
winfo geometry .pack.red
-} 100x50+0+50
-test oldpack-4.4 {filling} {
+} -result 100x50+0+50
+test oldpack-4.4 {filling} -body {
pack append .pack .pack.red {right padx 20 pady 30 fillx}
update
winfo geometry .pack.red
-} 30x20+70+40
-test oldpack-4.5 {filling} {
+} -result 30x20+70+40
+test oldpack-4.5 {filling} -body {
pack append .pack .pack.red {right padx 20 pady 30 filly}
update
winfo geometry .pack.red
-} 10x100+80+0
-test oldpack-4.6 {filling} {
+} -result 10x100+80+0
+test oldpack-4.6 {filling} -body {
pack append .pack .pack.red {right padx 20 pady 30 fill}
update
winfo geometry .pack.red
-} 30x100+70+0
+} -result 30x100+70+0
# Multiple windows: make sure that space is properly subtracted
# from the cavity as windows are positioned inwards from all
@@ -219,57 +220,128 @@ test oldpack-4.6 {filling} {
# there isn't enough space for them.
pack append .pack .pack.red top .pack.green top .pack.blue top \
- .pack.violet top
+ .pack.violet top
update
-test oldpack-5.1 {multiple windows} {winfo geometry .pack.red} 10x20+45+0
-test oldpack-5.2 {multiple windows} {winfo geometry .pack.green} 30x40+35+20
-test oldpack-5.3 {multiple windows} {winfo geometry .pack.blue} 40x40+30+60
-test oldpack-5.4 {multiple windows} {winfo ismapped .pack.violet} 0
+test oldpack-5.1 {multiple windows} -body {
+ winfo geometry .pack.red
+} -result 10x20+45+0
+test oldpack-5.2 {multiple windows} -body {
+ winfo geometry .pack.green
+} -result 30x40+35+20
+test oldpack-5.3 {multiple windows} -body {
+ winfo geometry .pack.blue
+} -result 40x40+30+60
+test oldpack-5.4 {multiple windows} -body {
+ winfo ismapped .pack.violet
+} -result 0
+
pack b .pack.blue .pack.violet top
update
-test oldpack-5.5 {multiple windows} {winfo ismapped .pack.violet} 1
-test oldpack-5.6 {multiple windows} {winfo geometry .pack.violet} 80x20+10+60
-test oldpack-5.7 {multiple windows} {winfo geometry .pack.blue} 40x20+30+80
+test oldpack-5.5 {multiple windows} -body {
+ winfo ismapped .pack.violet
+} -result 1
+test oldpack-5.6 {multiple windows} -body {
+ winfo geometry .pack.violet
+} -result 80x20+10+60
+test oldpack-5.7 {multiple windows} -body {
+ winfo geometry .pack.blue
+} -result 40x20+30+80
+
pack after .pack.blue .pack.red top
update
-test oldpack-5.8 {multiple windows} {winfo geometry .pack.green} 30x40+35+0
-test oldpack-5.9 {multiple windows} {winfo geometry .pack.violet} 80x20+10+40
-test oldpack-5.10 {multiple windows} {winfo geometry .pack.blue} 40x40+30+60
-test oldpack-5.11 {multiple windows} {winfo ismapped .pack.red} 0
+test oldpack-5.8 {multiple windows} -body {
+ winfo geometry .pack.green
+} -result 30x40+35+0
+test oldpack-5.9 {multiple windows} -body {
+ winfo geometry .pack.violet
+} -result 80x20+10+40
+test oldpack-5.10 {multiple windows} -body {
+ winfo geometry .pack.blue
+} -result 40x40+30+60
+test oldpack-5.11 {multiple windows} -body {
+ winfo ismapped .pack.red
+} -result 0
+
pack before .pack.green .pack.red right .pack.blue left
update
-test oldpack-5.12 {multiple windows} {winfo ismapped .pack.red} 1
-test oldpack-5.13 {multiple windows} {winfo geometry .pack.red} 10x20+90+40
-test oldpack-5.14 {multiple windows} {winfo geometry .pack.blue} 40x40+0+30
-test oldpack-5.15 {multiple windows} {winfo geometry .pack.green} 30x40+50+0
-test oldpack-5.16 {multiple windows} {winfo geometry .pack.violet} 50x20+40+40
+test oldpack-5.12 {multiple windows} -body {
+ winfo ismapped .pack.red
+} -result 1
+test oldpack-5.13 {multiple windows} -body {
+ winfo geometry .pack.red
+} -result 10x20+90+40
+test oldpack-5.14 {multiple windows} -body {
+ winfo geometry .pack.blue
+} -result 40x40+0+30
+test oldpack-5.15 {multiple windows} -body {
+ winfo geometry .pack.green
+} -result 30x40+50+0
+test oldpack-5.16 {multiple windows} -body {
+ winfo geometry .pack.violet
+} -result 50x20+40+40
+
pack append .pack .pack.violet left .pack.green bottom .pack.red bottom \
- .pack.blue bottom
+ .pack.blue bottom
update
-test oldpack-5.17 {multiple windows} {winfo geometry .pack.violet} 80x20+0+40
-test oldpack-5.18 {multiple windows} {winfo geometry .pack.green} 20x40+80+60
-test oldpack-5.19 {multiple windows} {winfo geometry .pack.red} 10x20+85+40
-test oldpack-5.20 {multiple windows} {winfo geometry .pack.blue} 20x40+80+0
+test oldpack-5.17 {multiple windows} -body {
+ winfo geometry .pack.violet
+} -result 80x20+0+40
+test oldpack-5.18 {multiple windows} -body {
+ winfo geometry .pack.green
+} -result 20x40+80+60
+test oldpack-5.19 {multiple windows} -body {
+ winfo geometry .pack.red
+} -result 10x20+85+40
+test oldpack-5.20 {multiple windows} -body {
+ winfo geometry .pack.blue
+} -result 20x40+80+0
+
pack after .pack.blue .pack.blue top .pack.red right .pack.green right \
- .pack.violet right
+ .pack.violet right
update
-test oldpack-5.21 {multiple windows} {winfo geometry .pack.blue} 40x40+30+0
-test oldpack-5.22 {multiple windows} {winfo geometry .pack.red} 10x20+90+60
-test oldpack-5.23 {multiple windows} {winfo geometry .pack.green} 30x40+60+50
-test oldpack-5.24 {multiple windows} {winfo geometry .pack.violet} 60x20+0+60
+test oldpack-5.21 {multiple windows} -body {
+ winfo geometry .pack.blue
+} -result 40x40+30+0
+test oldpack-5.22 {multiple windows} -body {
+ winfo geometry .pack.red
+} -result 10x20+90+60
+test oldpack-5.23 {multiple windows} -body {
+ winfo geometry .pack.green
+} -result 30x40+60+50
+test oldpack-5.24 {multiple windows} -body {
+ winfo geometry .pack.violet
+} -result 60x20+0+60
+
pack after .pack.blue .pack.red left .pack.green left .pack.violet left
update
-test oldpack-5.25 {multiple windows} {winfo geometry .pack.blue} 40x40+30+0
-test oldpack-5.26 {multiple windows} {winfo geometry .pack.red} 10x20+0+60
-test oldpack-5.27 {multiple windows} {winfo geometry .pack.green} 30x40+10+50
-test oldpack-5.28 {multiple windows} {winfo geometry .pack.violet} 60x20+40+60
+test oldpack-5.25 {multiple windows} -body {
+ winfo geometry .pack.blue
+} -result 40x40+30+0
+test oldpack-5.26 {multiple windows} -body {
+ winfo geometry .pack.red
+} -result 10x20+0+60
+test oldpack-5.27 {multiple windows} -body {
+ winfo geometry .pack.green
+} -result 30x40+10+50
+test oldpack-5.28 {multiple windows} -body {
+ winfo geometry .pack.violet
+} -result 60x20+40+60
+
pack append .pack .pack.violet left .pack.green left .pack.blue left \
- .pack.red left
+ .pack.red left
update
-test oldpack-5.29 {multiple windows} {winfo geometry .pack.violet} 80x20+0+40
-test oldpack-5.30 {multiple windows} {winfo geometry .pack.green} 20x40+80+30
-test oldpack-5.31 {multiple windows} {winfo ismapped .pack.blue} 0
-test oldpack-5.32 {multiple windows} {winfo ismapped .pack.red} 0
+test oldpack-5.29 {multiple windows} -body {
+ winfo geometry .pack.violet
+} -result 80x20+0+40
+test oldpack-5.30 {multiple windows} -body {
+ winfo geometry .pack.green
+} -result 20x40+80+30
+test oldpack-5.31 {multiple windows} -body {
+ winfo ismapped .pack.blue
+} -result 0
+test oldpack-5.32 {multiple windows} -body {
+ winfo ismapped .pack.red
+} -result 0
# Test the ability of the packer to propagate geometry information
@@ -279,84 +351,92 @@ test oldpack-5.32 {multiple windows} {winfo ismapped .pack.red} 0
# "left" and "right" windows).
pack append .pack .pack.red top .pack.green top .pack.blue top \
- .pack.violet top
+ .pack.violet top
update
-test oldpack-6.1 {geometry propagation} {winfo reqwidth .pack} 80
-test oldpack-6.2 {geometry propagation} {winfo reqheight .pack} 120
+test oldpack-6.1 {geometry propagation} -body {
+ winfo reqwidth .pack} -result 80
+test oldpack-6.2 {geometry propagation} -body {
+ winfo reqheight .pack} -result 120
destroy .pack.violet
update
-test oldpack-6.3 {geometry propagation} {winfo reqwidth .pack} 40
-test oldpack-6.4 {geometry propagation} {winfo reqheight .pack} 100
+test oldpack-6.3 {geometry propagation} -body {
+ winfo reqwidth .pack} -result 40
+test oldpack-6.4 {geometry propagation} -body {
+ winfo reqheight .pack} -result 100
frame .pack.violet -width 80 -height 20 -bg violet
label .pack.violet.l -text P -bd 2 -relief raised
place .pack.violet.l -relwidth 1.0 -relheight 1.0
pack append .pack .pack.red left .pack.green right .pack.blue bottom \
- .pack.violet top
+ .pack.violet top
update
-test oldpack-6.5 {geometry propagation} {winfo reqwidth .pack} 120
-test oldpack-6.6 {geometry propagation} {winfo reqheight .pack} 60
+test oldpack-6.5 {geometry propagation} -body {
+ winfo reqwidth .pack} -result 120
+test oldpack-6.6 {geometry propagation} -body {
+ winfo reqheight .pack} -result 60
pack append .pack .pack.violet top .pack.green top .pack.blue left \
- .pack.red left
+ .pack.red left
update
-test oldpack-6.7 {geometry propagation} {winfo reqwidth .pack} 80
-test oldpack-6.8 {geometry propagation} {winfo reqheight .pack} 100
+test oldpack-6.7 {geometry propagation} -body {
+ winfo reqwidth .pack} -result 80
+test oldpack-6.8 {geometry propagation} -body {
+ winfo reqheight .pack} -result 100
# Test the "expand" option, and make sure space is evenly divided
# when several windows request expansion.
pack append .pack .pack.violet top .pack.green {left e} \
- .pack.blue {left expand} .pack.red {left expand}
+ .pack.blue {left expand} .pack.red {left expand}
update
-test oldpack-7.1 {multiple expanded windows} {
+test oldpack-7.1 {multiple expanded windows} -body {
pack append .pack .pack.violet top .pack.green {left e} \
- .pack.blue {left expand} .pack.red {left expand}
+ .pack.blue {left expand} .pack.red {left expand}
update
list [winfo geometry .pack.green] [winfo geometry .pack.blue] \
- [winfo geometry .pack.red]
-} {30x40+3+40 40x40+39+40 10x20+86+50}
-test oldpack-7.2 {multiple expanded windows} {
+ [winfo geometry .pack.red]
+} -result {30x40+3+40 40x40+39+40 10x20+86+50}
+test oldpack-7.2 {multiple expanded windows} -body {
pack append .pack .pack.green left .pack.violet {bottom expand} \
- .pack.blue {bottom expand} .pack.red {bottom expand}
+ .pack.blue {bottom expand} .pack.red {bottom expand}
update
list [winfo geometry .pack.violet] [winfo geometry .pack.blue] \
- [winfo geometry .pack.red]
-} {70x20+30+77 40x40+45+30 10x20+60+3}
-test oldpack-7.3 {multiple expanded windows} {
+ [winfo geometry .pack.red]
+} -result {70x20+30+77 40x40+45+30 10x20+60+3}
+test oldpack-7.3 {multiple expanded windows} -body {
foreach i [winfo child .pack] {
- pack unpack $i
+ pack unpack $i
}
pack append .pack .pack.green {left e fill} .pack.red {left expand fill} \
- .pack.blue {top fill}
+ .pack.blue {top fill}
update
list [winfo geometry .pack.green] [winfo geometry .pack.red] \
- [winfo geometry .pack.blue]
-} {40x100+0+0 20x100+40+0 40x40+60+0}
-test oldpack-7.4 {multiple expanded windows} {
+ [winfo geometry .pack.blue]
+} -result {40x100+0+0 20x100+40+0 40x40+60+0}
+test oldpack-7.4 {multiple expanded windows} -body {
foreach i [winfo child .pack] {
- pack unpack $i
+ pack unpack $i
}
pack append .pack .pack.red {top expand} .pack.violet {top expand} \
- .pack.blue {right fill}
+ .pack.blue {right fill}
update
list [winfo geometry .pack.red] [winfo geometry .pack.violet] \
- [winfo geometry .pack.blue]
-} {10x20+45+5 80x20+10+35 40x40+60+60}
-test oldpack-7.5 {multiple expanded windows} {
+ [winfo geometry .pack.blue]
+} -result {10x20+45+5 80x20+10+35 40x40+60+60}
+test oldpack-7.5 {multiple expanded windows} -body {
foreach i [winfo child .pack] {
- pack unpack $i
+ pack unpack $i
}
pack append .pack .pack.green {right frame s} .pack.red {top expand}
update
list [winfo geometry .pack.green] [winfo geometry .pack.red]
-} {30x40+70+60 10x20+30+40}
-test oldpack-7.6 {multiple expanded windows} {
+} -result {30x40+70+60 10x20+30+40}
+test oldpack-7.6 {multiple expanded windows} -body {
foreach i [winfo child .pack] {
- pack unpack $i
+ pack unpack $i
}
pack append .pack .pack.violet {bottom frame e} .pack.red {right expand}
update
list [winfo geometry .pack.violet] [winfo geometry .pack.red]
-} {80x20+20+80 10x20+45+30}
+} -result {80x20+20+80 10x20+45+30}
# Need more bizarre tests with combinations of expanded windows and
# windows in opposing directions! Also, include padding in expanded
@@ -364,146 +444,109 @@ test oldpack-7.6 {multiple expanded windows} {
# Syntax errors on pack commands
-test oldpack-8.1 {syntax errors} {
- set msg ""
- set result [catch {pack} msg]
- concat $result $msg
-} {1 wrong # args: should be "pack option arg ?arg ...?"}
-test oldpack-8.2 {syntax errors} {
- set msg ""
- set result [catch {pack append} msg]
- concat $result $msg
-} {1 wrong # args: should be "pack option arg ?arg ...?"}
-test oldpack-8.3 {syntax errors} {
- set msg ""
- set result [catch {pack gorp foo} msg]
- concat $result $msg
-} {1 bad option "gorp": must be configure, forget, info, propagate, or slaves}
-test oldpack-8.4 {syntax errors} {
- set msg ""
- set result [catch {pack a .pack} msg]
- concat $result $msg
-} {1 bad option "a": must be configure, forget, info, propagate, or slaves}
-test oldpack-8.5 {syntax errors} {
- set msg ""
- set result [catch {pack after foobar} msg]
- concat $result $msg
-} {1 bad window path name "foobar"}
-test oldpack-8.6 {syntax errors} {
+test oldpack-8.1 {syntax errors} -body {
+ pack
+} -returnCodes error -result {wrong # args: should be "pack option arg ?arg ...?"}
+test oldpack-8.2 {syntax errors} -body {
+ pack append
+} -returnCodes error -result {wrong # args: should be "pack option arg ?arg ...?"}
+test oldpack-8.3 {syntax errors} -body {
+ pack gorp foo
+} -returnCodes error -result {bad option "gorp": must be configure, forget, info, propagate, or slaves}
+test oldpack-8.4 {syntax errors} -body {
+ pack a .pack
+} -returnCodes error -result {bad option "a": must be configure, forget, info, propagate, or slaves}
+test oldpack-8.5 {syntax errors} -body {
+ pack after foobar
+} -returnCodes error -result {bad window path name "foobar"}
+test oldpack-8.6 {syntax errors} -setup {
+ destroy .pack.yellow
+} -body {
frame .pack.yellow -bg yellow
- set msg ""
- set result [catch {pack after .pack.yellow} msg]
+ pack after .pack.yellow
+} -cleanup {
destroy .pack.yellow
- concat $result $msg
-} {1 window ".pack.yellow" isn't packed}
-test oldpack-8.7 {syntax errors} {
- set msg ""
- set result [catch {pack append foobar} msg]
- concat $result $msg
-} {1 bad window path name "foobar"}
-test oldpack-8.8 {syntax errors} {
- set msg ""
- set result [catch {pack before foobar} msg]
- concat $result $msg
-} {1 bad window path name "foobar"}
-test oldpack-8.9 {syntax errors} {
+} -returnCodes error -result {window ".pack.yellow" isn't packed}
+test oldpack-8.7 {syntax errors} -body {
+ pack append foobar
+} -returnCodes error -result {bad window path name "foobar"}
+test oldpack-8.8 {syntax errors} -body {
+ pack before foobar
+} -returnCodes error -result {bad window path name "foobar"}
+test oldpack-8.9 {syntax errors} -setup {
+ destroy .pack.yellow
+} -body {
frame .pack.yellow -bg yellow
- set msg ""
- set result [catch {pack before .pack.yellow} msg]
+ pack before .pack.yellow
+} -cleanup {
destroy .pack.yellow
- concat $result $msg
-} {1 window ".pack.yellow" isn't packed}
-test oldpack-8.10 {syntax errors} {
- set msg ""
- set result [catch {pack info .pack help} msg]
- concat $result $msg
-} {1 wrong # args: should be "pack info window"}
-test oldpack-8.11 {syntax errors} {
- set msg ""
- set result [catch {pack info foobar} msg]
- concat $result $msg
-} {1 bad window path name "foobar"}
-test oldpack-8.12 {syntax errors} {
- set msg ""
- set result [catch {pack append .pack .pack.blue} msg]
- concat $result $msg
-} {1 wrong # args: window ".pack.blue" should be followed by options}
-test oldpack-8.13 {syntax errors} {
- set msg ""
- set result [catch {pack append . .pack.blue top} msg]
- concat $result $msg
-} {1 can't pack .pack.blue inside .}
-test oldpack-8.14 {syntax errors} {
- set msg ""
- set result [catch {pack append .pack .pack.blue f} msg]
- concat $result $msg
-} {1 bad option "f": should be top, bottom, left, right, expand, fill, fillx, filly, padx, pady, or frame}
-test oldpack-8.15 {syntax errors} {
- set msg ""
- set result [catch {pack append .pack .pack.blue pad} msg]
- concat $result $msg
-} {1 bad option "pad": should be top, bottom, left, right, expand, fill, fillx, filly, padx, pady, or frame}
-test oldpack-8.16 {syntax errors} {
- set msg ""
- set result [catch {pack append .pack .pack.blue {frame south}} msg]
- concat $result $msg
-} {1 bad anchor "south": must be n, ne, e, se, s, sw, w, nw, or center}
-test oldpack-8.17 {syntax errors} {
- set msg ""
- set result [catch {pack append .pack .pack.blue {padx -2}} msg]
- concat $result $msg
-} {1 bad pad value "-2": must be positive screen distance}
-test oldpack-8.18 {syntax errors} {
- set msg ""
- set result [catch {pack append .pack .pack.blue {padx}} msg]
- concat $result $msg
-} {1 wrong # args: "padx" option must be followed by screen distance}
-test oldpack-8.19 {syntax errors} {
- set msg ""
- set result [catch {pack append .pack .pack.blue {pady -2}} msg]
- concat $result $msg
-} {1 bad pad value "-2": must be positive screen distance}
-test oldpack-8.20 {syntax errors} {
- set msg ""
- set result [catch {pack append .pack .pack.blue {pady}} msg]
- concat $result $msg
-} {1 wrong # args: "pady" option must be followed by screen distance}
-test oldpack-8.21 {syntax errors} {
- set msg ""
- set result [catch {pack append .pack .pack.blue "\{abc"} msg]
- concat $result $msg
-} {1 unmatched open brace in list}
-test oldpack-8.22 {syntax errors} {
- set msg ""
- set result [catch {pack append .pack .pack.blue frame} msg]
- concat $result $msg
-} {1 wrong # args: "frame" option must be followed by anchor point}
+} -returnCodes error -result {window ".pack.yellow" isn't packed}
+test oldpack-8.10 {syntax errors} -body {
+ pack info .pack help
+} -returnCodes error -result {wrong # args: should be "pack info window"}
+test oldpack-8.11 {syntax errors} -body {
+ pack info foobar
+} -returnCodes error -result {bad window path name "foobar"}
+test oldpack-8.12 {syntax errors} -body {
+ pack append .pack .pack.blue
+} -returnCodes error -result {wrong # args: window ".pack.blue" should be followed by options}
+test oldpack-8.13 {syntax errors} -body {
+ pack append . .pack.blue top
+} -returnCodes error -result {can't pack .pack.blue inside .}
+test oldpack-8.14 {syntax errors} -body {
+ pack append .pack .pack.blue f
+} -returnCodes error -result {bad option "f": should be top, bottom, left, right, expand, fill, fillx, filly, padx, pady, or frame}
+test oldpack-8.15 {syntax errors} -body {
+ pack append .pack .pack.blue pad
+} -returnCodes error -result {bad option "pad": should be top, bottom, left, right, expand, fill, fillx, filly, padx, pady, or frame}
+test oldpack-8.16 {syntax errors} -body {
+ pack append .pack .pack.blue {frame south}
+} -returnCodes error -result {bad anchor "south": must be n, ne, e, se, s, sw, w, nw, or center}
+test oldpack-8.17 {syntax errors} -body {
+ pack append .pack .pack.blue {padx -2}
+} -returnCodes error -result {bad pad value "-2": must be positive screen distance}
+test oldpack-8.18 {syntax errors} -body {
+ pack append .pack .pack.blue {padx}
+} -returnCodes error -result {wrong # args: "padx" option must be followed by screen distance}
+test oldpack-8.19 {syntax errors} -body {
+ pack append .pack .pack.blue {pady -2}
+} -returnCodes error -result {bad pad value "-2": must be positive screen distance}
+test oldpack-8.20 {syntax errors} -body {
+ pack append .pack .pack.blue {pady}
+} -returnCodes error -result {wrong # args: "pady" option must be followed by screen distance}
+test oldpack-8.21 {syntax errors} -body {
+ pack append .pack .pack.blue "\{abc"
+} -returnCodes error -result {unmatched open brace in list}
+test oldpack-8.22 {syntax errors} -body {
+ pack append .pack .pack.blue frame
+} -returnCodes error -result {wrong # args: "frame" option must be followed by anchor point}
# Test "pack info" command output.
-test oldpack-9.1 {information output} {
+test oldpack-9.1 {information output} -body {
pack append .pack .pack.blue {top fillx frame n} \
- .pack.red {bottom filly frame s} .pack.green {left fill frame w} \
- .pack.violet {right expand frame e}
+ .pack.red {bottom filly frame s} .pack.green {left fill frame w} \
+ .pack.violet {right expand frame e}
list [pack slaves .pack] [pack info .pack.blue] [pack info .pack.red] \
- [pack info .pack.green] [pack info .pack.violet]
-} {{.pack.blue .pack.red .pack.green .pack.violet} {-in .pack -anchor n -expand 0 -fill x -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor s -expand 0 -fill y -ipadx 0 -ipady 0 -padx 0 -pady 0 -side bottom} {-in .pack -anchor w -expand 0 -fill both -ipadx 0 -ipady 0 -padx 0 -pady 0 -side left} {-in .pack -anchor e -expand 1 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side right}}
-test oldpack-9.2 {information output} {
+ [pack info .pack.green] [pack info .pack.violet]
+} -result {{.pack.blue .pack.red .pack.green .pack.violet} {-in .pack -anchor n -expand 0 -fill x -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor s -expand 0 -fill y -ipadx 0 -ipady 0 -padx 0 -pady 0 -side bottom} {-in .pack -anchor w -expand 0 -fill both -ipadx 0 -ipady 0 -padx 0 -pady 0 -side left} {-in .pack -anchor e -expand 1 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side right}}
+test oldpack-9.2 {information output} -body {
pack append .pack .pack.blue {padx 10 frame nw} \
- .pack.red {pady 20 frame ne} .pack.green {frame se} \
- .pack.violet {frame sw}
+ .pack.red {pady 20 frame ne} .pack.green {frame se} \
+ .pack.violet {frame sw}
list [pack slaves .pack] [pack info .pack.blue] [pack info .pack.red] \
- [pack info .pack.green] [pack info .pack.violet]
-} {{.pack.blue .pack.red .pack.green .pack.violet} {-in .pack -anchor nw -expand 0 -fill none -ipadx 0 -ipady 0 -padx 5 -pady 0 -side top} {-in .pack -anchor ne -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 10 -side top} {-in .pack -anchor se -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor sw -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top}}
-test oldpack-9.3 {information output} {
+ [pack info .pack.green] [pack info .pack.violet]
+} -result {{.pack.blue .pack.red .pack.green .pack.violet} {-in .pack -anchor nw -expand 0 -fill none -ipadx 0 -ipady 0 -padx 5 -pady 0 -side top} {-in .pack -anchor ne -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 10 -side top} {-in .pack -anchor se -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor sw -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top}}
+test oldpack-9.3 {information output} -body {
pack append .pack .pack.blue {frame center} .pack.red {frame center} \
- .pack.green {frame c} .pack.violet {frame c}
+ .pack.green {frame c} .pack.violet {frame c}
list [pack slaves .pack] [pack info .pack.blue] [pack info .pack.red] \
- [pack info .pack.green] [pack info .pack.violet]
-} {{.pack.blue .pack.red .pack.green .pack.violet} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top}}
+ [pack info .pack.green] [pack info .pack.violet]
+} -result {{.pack.blue .pack.red .pack.green .pack.violet} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top}}
-catch {destroy .pack}
+destroy .pack
# cleanup
cleanupTests
return
+
diff --git a/tests/option.test b/tests/option.test
index 49d2975..66df70c 100644
--- a/tests/option.test
+++ b/tests/option.test
@@ -6,14 +6,14 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
testConstraint appNameIsTktest [expr {[winfo name .] eq "tktest"}]
-catch {destroy .op1}
-catch {destroy .op2}
+deleteWindows
set appName [winfo name .]
# First, test basic retrievals, being sure to trigger all the various
@@ -27,6 +27,7 @@ frame .op1.op4 -class Class3
frame .op2.op5 -class Class2
frame .op1.op3.op6 -class Class4
+# Configurations for tests 1.* - 12.*
option clear
option add *Color1 red
option add *x blue
@@ -38,97 +39,254 @@ option add $appName.Class1.Class3.y brown
option add $appName*op6*Color2 black
option add $appName*Class1.op1.Color2 grey
-test option-1.1 {basic option retrieval} {option get . x Color1} blue
-test option-1.2 {basic option retrieval} {option get . y Color1} red
-test option-1.3 {basic option retrieval} {option get . z Color1} red
-test option-1.4 {basic option retrieval} {option get . x Color2} blue
-test option-1.5 {basic option retrieval} {option get . y Color2} {}
-test option-1.6 {basic option retrieval} {option get . z Color2} {}
-
-test option-2.1 {basic option retrieval} {option get .op1 x Color1} green
-test option-2.2 {basic option retrieval} {option get .op1 y Color1} red
-test option-2.3 {basic option retrieval} {option get .op1 z Color1} red
-test option-2.4 {basic option retrieval} {option get .op1 x Color2} green
-test option-2.5 {basic option retrieval} {option get .op1 y Color2} {}
-test option-2.6 {basic option retrieval} {option get .op1 z Color2} {}
-
-test option-3.1 {basic option retrieval} {option get .op1.op3 x Color1} yellow
-test option-3.2 {basic option retrieval} {option get .op1.op3 y Color1} red
-test option-3.3 {basic option retrieval} {option get .op1.op3 z Color1} red
-test option-3.4 {basic option retrieval} {option get .op1.op3 x Color2} yellow
-test option-3.5 {basic option retrieval} {option get .op1.op3 y Color2} {}
-test option-3.6 {basic option retrieval} {option get .op1.op3 z Color2} {}
-
-test option-4.1 {basic option retrieval} {option get .op1.op3.op6 x Color1} blue
-test option-4.2 {basic option retrieval} {option get .op1.op3.op6 y Color1} red
-test option-4.3 {basic option retrieval} {option get .op1.op3.op6 z Color1} red
-test option-4.4 {basic option retrieval} {option get .op1.op3.op6 x Color2} black
-test option-4.5 {basic option retrieval} {option get .op1.op3.op6 y Color2} black
-test option-4.6 {basic option retrieval} {option get .op1.op3.op6 z Color2} black
-
-test option-5.1 {basic option retrieval} {option get .op1.op4 x Color1} blue
-test option-5.2 {basic option retrieval} {option get .op1.op4 y Color1} brown
-test option-5.3 {basic option retrieval} {option get .op1.op4 z Color1} red
-test option-5.4 {basic option retrieval} {option get .op1.op4 x Color2} blue
-test option-5.5 {basic option retrieval} {option get .op1.op4 y Color2} brown
-test option-5.6 {basic option retrieval} {option get .op1.op4 z Color2} {}
-
-test option-6.1 {basic option retrieval} {option get .op2 x Color1} orange
-test option-6.2 {basic option retrieval} {option get .op2 y Color1} orange
-test option-6.3 {basic option retrieval} {option get .op2 z Color1} orange
-test option-6.4 {basic option retrieval} {option get .op2 x Color2} blue
-test option-6.5 {basic option retrieval} {option get .op2 y Color2} {}
-test option-6.6 {basic option retrieval} {option get .op2 z Color2} {}
-
-test option-7.1 {basic option retrieval} {option get .op2.op5 x Color1} orange
-test option-7.2 {basic option retrieval} {option get .op2.op5 y Color1} orange
-test option-7.3 {basic option retrieval} {option get .op2.op5 z Color1} orange
-test option-7.4 {basic option retrieval} {option get .op2.op5 x Color2} purple
-test option-7.5 {basic option retrieval} {option get .op2.op5 y Color2} purple
-test option-7.6 {basic option retrieval} {option get .op2.op5 z Color2} purple
+test option-1.1 {basic option retrieval} -body {
+ option get . x Color1
+} -result blue
+test option-1.2 {basic option retrieval} -body {
+ option get . y Color1
+} -result red
+test option-1.3 {basic option retrieval} -body {
+ option get . z Color1
+} -result red
+test option-1.4 {basic option retrieval} -body {
+ option get . x Color2
+} -result blue
+test option-1.5 {basic option retrieval} -body {
+ option get . y Color2
+} -result {}
+test option-1.6 {basic option retrieval} -body {
+ option get . z Color2
+} -result {}
+
+
+test option-2.1 {basic option retrieval} -body {
+ option get .op1 x Color1
+} -result green
+test option-2.2 {basic option retrieval} -body {
+ option get .op1 y Color1
+} -result red
+test option-2.3 {basic option retrieval} -body {
+ option get .op1 z Color1
+} -result red
+test option-2.4 {basic option retrieval} -body {
+ option get .op1 x Color2
+} -result green
+test option-2.5 {basic option retrieval} -body {
+ option get .op1 y Color2
+} -result {}
+test option-2.6 {basic option retrieval} -body {
+ option get .op1 z Color2
+} -result {}
+
+
+test option-3.1 {basic option retrieval} -body {
+ option get .op1.op3 x Color1
+} -result yellow
+test option-3.2 {basic option retrieval} -body {
+ option get .op1.op3 y Color1
+} -result red
+test option-3.3 {basic option retrieval} -body {
+ option get .op1.op3 z Color1
+} -result red
+test option-3.4 {basic option retrieval} -body {
+ option get .op1.op3 x Color2
+} -result yellow
+test option-3.5 {basic option retrieval} -body {
+ option get .op1.op3 y Color2
+} -result {}
+test option-3.6 {basic option retrieval} -body {
+ option get .op1.op3 z Color2
+} -result {}
+
+
+test option-4.1 {basic option retrieval} -body {
+ option get .op1.op3.op6 x Color1
+} -result blue
+test option-4.2 {basic option retrieval} -body {
+ option get .op1.op3.op6 y Color1
+} -result red
+test option-4.3 {basic option retrieval} -body {
+ option get .op1.op3.op6 z Color1
+} -result red
+test option-4.4 {basic option retrieval} -body {
+ option get .op1.op3.op6 x Color2
+} -result black
+test option-4.5 {basic option retrieval} -body {
+ option get .op1.op3.op6 y Color2
+} -result black
+test option-4.6 {basic option retrieval} -body {
+ option get .op1.op3.op6 z Color2
+} -result black
+
+
+test option-5.1 {basic option retrieval} -body {
+ option get .op1.op4 x Color1
+} -result blue
+test option-5.2 {basic option retrieval} -body {
+ option get .op1.op4 y Color1
+} -result brown
+test option-5.3 {basic option retrieval} -body {
+ option get .op1.op4 z Color1
+} -result red
+test option-5.4 {basic option retrieval} -body {
+ option get .op1.op4 x Color2
+} -result blue
+test option-5.5 {basic option retrieval} -body {
+ option get .op1.op4 y Color2
+} -result brown
+test option-5.6 {basic option retrieval} -body {
+ option get .op1.op4 z Color2
+} -result {}
+
+
+test option-6.1 {basic option retrieval} -body {
+ option get .op2 x Color1
+} -result orange
+test option-6.2 {basic option retrieval} -body {
+ option get .op2 y Color1
+} -result orange
+test option-6.3 {basic option retrieval} -body {
+ option get .op2 z Color1
+} -result orange
+test option-6.4 {basic option retrieval} -body {
+ option get .op2 x Color2
+} -result blue
+test option-6.5 {basic option retrieval} -body {
+ option get .op2 y Color2
+} -result {}
+test option-6.6 {basic option retrieval} -body {
+ option get .op2 z Color2
+} -result {}
+
+
+test option-7.1 {basic option retrieval} -body {
+ option get .op2.op5 x Color1
+} -result orange
+test option-7.2 {basic option retrieval} -body {
+ option get .op2.op5 y Color1
+} -result orange
+test option-7.3 {basic option retrieval} -body {
+ option get .op2.op5 z Color1
+} -result orange
+test option-7.4 {basic option retrieval} -body {
+ option get .op2.op5 x Color2
+} -result purple
+test option-7.5 {basic option retrieval} -body {
+ option get .op2.op5 y Color2
+} -result purple
+test option-7.6 {basic option retrieval} -body {
+ option get .op2.op5 z Color2
+} -result purple
+
# Now try similar tests to above, except jump around non-hierarchically
# between windows to make sure that the option stacks are pushed and
# popped correctly.
option get . foo Foo
-test option-8.1 {stack pushing/popping} {option get .op2.op5 x Color1} orange
-test option-8.2 {stack pushing/popping} {option get .op2.op5 y Color1} orange
-test option-8.3 {stack pushing/popping} {option get .op2.op5 z Color1} orange
-test option-8.4 {stack pushing/popping} {option get .op2.op5 x Color2} purple
-test option-8.5 {stack pushing/popping} {option get .op2.op5 y Color2} purple
-test option-8.6 {stack pushing/popping} {option get .op2.op5 z Color2} purple
-
-test option-9.1 {stack pushing/popping} {option get . x Color1} blue
-test option-9.2 {stack pushing/popping} {option get . y Color1} red
-test option-9.3 {stack pushing/popping} {option get . z Color1} red
-test option-9.4 {stack pushing/popping} {option get . x Color2} blue
-test option-9.5 {stack pushing/popping} {option get . y Color2} {}
-test option-9.6 {stack pushing/popping} {option get . z Color2} {}
-
-test option-10.1 {stack pushing/popping} {option get .op1.op3.op6 x Color1} blue
-test option-10.2 {stack pushing/popping} {option get .op1.op3.op6 y Color1} red
-test option-10.3 {stack pushing/popping} {option get .op1.op3.op6 z Color1} red
-test option-10.4 {stack pushing/popping} {option get .op1.op3.op6 x Color2} black
-test option-10.5 {stack pushing/popping} {option get .op1.op3.op6 y Color2} black
-test option-10.6 {stack pushing/popping} {option get .op1.op3.op6 z Color2} black
-
-test option-11.1 {stack pushing/popping} {option get .op1.op3 x Color1} yellow
-test option-11.2 {stack pushing/popping} {option get .op1.op3 y Color1} red
-test option-11.3 {stack pushing/popping} {option get .op1.op3 z Color1} red
-test option-11.4 {stack pushing/popping} {option get .op1.op3 x Color2} yellow
-test option-11.5 {stack pushing/popping} {option get .op1.op3 y Color2} {}
-test option-11.6 {stack pushing/popping} {option get .op1.op3 z Color2} {}
-
-test option-12.1 {stack pushing/popping} {option get .op1 x Color1} green
-test option-12.2 {stack pushing/popping} {option get .op1 y Color1} red
-test option-12.3 {stack pushing/popping} {option get .op1 z Color1} red
-test option-12.4 {stack pushing/popping} {option get .op1 x Color2} green
-test option-12.5 {stack pushing/popping} {option get .op1 y Color2} {}
-test option-12.6 {stack pushing/popping} {option get .op1 z Color2} {}
+test option-8.1 {stack pushing/popping} -body {
+ option get .op2.op5 x Color1
+} -result orange
+test option-8.2 {stack pushing/popping} -body {
+ option get .op2.op5 y Color1
+} -result orange
+test option-8.3 {stack pushing/popping} -body {
+ option get .op2.op5 z Color1
+} -result orange
+test option-8.4 {stack pushing/popping} -body {
+ option get .op2.op5 x Color2
+} -result purple
+test option-8.5 {stack pushing/popping} -body {
+ option get .op2.op5 y Color2
+} -result purple
+test option-8.6 {stack pushing/popping} -body {
+ option get .op2.op5 z Color2
+} -result purple
+
+
+test option-9.1 {stack pushing/popping} -body {
+ option get . x Color1
+} -result blue
+test option-9.2 {stack pushing/popping} -body {
+ option get . y Color1
+} -result red
+test option-9.3 {stack pushing/popping} -body {
+ option get . z Color1
+} -result red
+test option-9.4 {stack pushing/popping} -body {
+ option get . x Color2
+} -result blue
+test option-9.5 {stack pushing/popping} -body {
+ option get . y Color2
+} -result {}
+test option-9.6 {stack pushing/popping} -body {
+ option get . z Color2
+} -result {}
+
+
+test option-10.1 {stack pushing/popping} -body {
+ option get .op1.op3.op6 x Color1
+} -result blue
+test option-10.2 {stack pushing/popping} -body {
+ option get .op1.op3.op6 y Color1
+} -result red
+test option-10.3 {stack pushing/popping} -body {
+ option get .op1.op3.op6 z Color1
+} -result red
+test option-10.4 {stack pushing/popping} -body {
+ option get .op1.op3.op6 x Color2
+} -result black
+test option-10.5 {stack pushing/popping} -body {
+ option get .op1.op3.op6 y Color2
+} -result black
+test option-10.6 {stack pushing/popping} -body {
+ option get .op1.op3.op6 z Color2
+} -result black
+
+
+test option-11.1 {stack pushing/popping} -body {
+ option get .op1.op3 x Color1
+} -result yellow
+test option-11.2 {stack pushing/popping} -body {
+ option get .op1.op3 y Color1
+} -result red
+test option-11.3 {stack pushing/popping} -body {
+ option get .op1.op3 z Color1
+} -result red
+test option-11.4 {stack pushing/popping} -body {
+ option get .op1.op3 x Color2
+} -result yellow
+test option-11.5 {stack pushing/popping} -body {
+ option get .op1.op3 y Color2
+} -result {}
+test option-11.6 {stack pushing/popping} -body {
+ option get .op1.op3 z Color2
+} -result {}
+
+
+test option-12.1 {stack pushing/popping} -body {
+ option get .op1 x Color1
+} -result green
+test option-12.2 {stack pushing/popping} -body {
+ option get .op1 y Color1
+} -result red
+test option-12.3 {stack pushing/popping} -body {
+ option get .op1 z Color1
+} -result red
+test option-12.4 {stack pushing/popping} -body {
+ option get .op1 x Color2
+} -result green
+test option-12.5 {stack pushing/popping} -body {
+ option get .op1 y Color2
+} -result {}
+test option-12.6 {stack pushing/popping} -body {
+ option get .op1 z Color2
+} -result {}
# Test the major priority levels (widgetDefault, etc.)
+# Configurations for tests 13.*
+option clear
option add $appName.op1.a 100 100
option add $appName.op1.A interactive interactive
option add $appName.op1.b userDefault userDefault
@@ -136,92 +294,127 @@ option add $appName.op1.B startupFile startupFile
option add $appName.op1.c widgetDefault widgetDefault
option add $appName.op1.C 0 0
-test option-13.1 {priority levels} {option get .op1 a A} 100
-test option-13.2 {priority levels} {option get .op1 b A} interactive
-test option-13.3 {priority levels} {option get .op1 b B} userDefault
-test option-13.4 {priority levels} {option get .op1 c B} startupFile
-test option-13.5 {priority levels} {option get .op1 c C} widgetDefault
+test option-13.1 {priority levels} -body {
+ option get .op1 a A
+} -result 100
+test option-13.2 {priority levels} -body {
+ option get .op1 b A
+} -result interactive
+test option-13.3 {priority levels} -body {
+ option get .op1 b B
+} -result userDefault
+test option-13.4 {priority levels} -body {
+ option get .op1 c B
+} -result startupFile
+test option-13.5 {priority levels} -body {
+ option get .op1 c C
+} -result widgetDefault
option add $appName.op1.B file2 widget
-test option-13.6 {priority levels} {option get .op1 c B} startupFile
+test option-13.6 {priority levels} -body {
+ option get .op1 c B
+} -result startupFile
option add $appName.op1.B file2 startupFile
-test option-13.7 {priority levels} {option get .op1 c B} file2
+test option-13.7 {priority levels} -body {
+ option get .op1 c B
+} -result file2
+
# Test various error conditions
-test option-14.1 {error conditions} {
- list [catch {option} msg] $msg
-} {1 {wrong # args: should be "option cmd arg ?arg ...?"}}
-test option-14.2 {error conditions} {
- list [catch {option x} msg] $msg
-} {1 {bad option "x": must be add, clear, get, or readfile}}
-test option-14.3 {error conditions} {
- list [catch {option foo 3} msg] $msg
-} {1 {bad option "foo": must be add, clear, get, or readfile}}
-test option-14.4 {error conditions} {
- list [catch {option add 3} msg] $msg
-} {1 {wrong # args: should be "option add pattern value ?priority?"}}
-test option-14.5 {error conditions} {
- list [catch {option add . a b c} msg] $msg
-} {1 {wrong # args: should be "option add pattern value ?priority?"}}
-test option-14.6 {error conditions} {
- list [catch {option add . a -1} msg] $msg
-} {1 {bad priority level "-1": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}}
-test option-14.7 {error conditions} {
- list [catch {option add . a 101} msg] $msg
-} {1 {bad priority level "101": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}}
-test option-14.8 {error conditions} {
- list [catch {option add . a gorp} msg] $msg
-} {1 {bad priority level "gorp": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}}
-test option-14.9 {error conditions} {
- list [catch {option get 3} msg] $msg
-} {1 {wrong # args: should be "option get window name class"}}
-test option-14.10 {error conditions} {
- list [catch {option get 3 4} msg] $msg
-} {1 {wrong # args: should be "option get window name class"}}
-test option-14.11 {error conditions} {
- list [catch {option get 3 4 5 6} msg] $msg
-} {1 {wrong # args: should be "option get window name class"}}
-test option-14.12 {error conditions} {
- list [catch {option get .gorp.gorp a A} msg] $msg
-} {1 {bad window path name ".gorp.gorp"}}
+test option-14.1 {error conditions} -body {
+ option
+} -returnCodes error -result {wrong # args: should be "option cmd arg ?arg ...?"}
+test option-14.2 {error conditions} -body {
+ option x
+} -returnCodes error -result {bad option "x": must be add, clear, get, or readfile}
+test option-14.3 {error conditions} -body {
+ option foo 3
+} -returnCodes error -result {bad option "foo": must be add, clear, get, or readfile}
+test option-14.4 {error conditions} -body {
+ option add 3
+} -returnCodes error -result {wrong # args: should be "option add pattern value ?priority?"}
+test option-14.5 {error conditions} -body {
+ option add . a b c
+} -returnCodes error -result {wrong # args: should be "option add pattern value ?priority?"}
+test option-14.6 {error conditions} -body {
+ option add . a -1
+} -returnCodes error -result {bad priority level "-1": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}
+test option-14.7 {error conditions} -body {
+ option add . a 101
+} -returnCodes error -result {bad priority level "101": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}
+test option-14.8 {error conditions} -body {
+ option add . a gorp
+} -returnCodes error -result {bad priority level "gorp": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}
+test option-14.9 {error conditions} -body {
+ option get 3
+} -returnCodes error -result {wrong # args: should be "option get window name class"}
+test option-14.10 {error conditions} -body {
+ option get 3 4
+} -returnCodes error -result {wrong # args: should be "option get window name class"}
+test option-14.11 {error conditions} -body {
+ option get 3 4 5 6
+} -returnCodes error -result {wrong # args: should be "option get window name class"}
+test option-14.12 {error conditions} -body {
+ option get .gorp.gorp a A
+} -returnCodes error -result {bad window path name ".gorp.gorp"}
+
set option1 [file join [testsDirectory] option.file1]
-set option2 [file join [testsDirectory] option.file2]
-
-test option-15.1 {database files} {
- list [catch {option read non-existent} msg] $msg
-} {1 {couldn't open "non-existent": no such file or directory}}
-option read $option1
-test option-15.2 {database files} {option get . x1 color} blue
-test option-15.3 {database files} appNameIsTktest {option get . x2 color} green
-test option-15.4 {database files} {option get . x3 color} purple
-test option-15.5 {database files} {option get . {x 4} color} brown
-test option-15.6 {database files} {option get . x6 color} {}
-test option-15.7 {database files} {
- list [catch {option read $option1 widget foo} msg] $msg
-} {1 {wrong # args: should be "option readfile fileName ?priority?"}}
-option add *x3 burgundy
-catch {option read $option1 userDefault}
-test option-15.8 {database files} {option get . x3 color} burgundy
-test option-15.9 {database files} {
- list [catch {option read $option2} msg] $msg
-} {1 {missing colon on line 2}}
-
-test option-16.1 {ReadOptionFile} {
+test option-15.1 {database files} -body {
+ option read non-existent
+} -returnCodes error -result {couldn't open "non-existent": no such file or directory}
+test option-15.2 {database files} -body {
+ option read $option1
+ option get . x1 color
+} -result blue
+test option-15.3 {database files} -constraints appNameIsTktest -body {
+ option read $option1
+ option get . x2 color
+} -result green
+test option-15.4 {database files} -body {
+ option read $option1
+ option get . x3 color
+} -result purple
+test option-15.5 {database files} -body {
+ option read $option1
+ option get . {x 4} color
+} -result brown
+test option-15.6 {database files} -body {
+ option read $option1
+ option get . x6 color
+} -result {}
+test option-15.7 {database files} -body {
+ option read $option1 widget foo
+} -returnCodes error -result {wrong # args: should be "option readfile fileName ?priority?"}
+
+test option-15.8 {database files} -body {
+ option add *x3 burgundy
+ catch {option read $option1 userDefault}
+ option get . x3 color
+} -result burgundy
+test option-15.9 {database files} -body {
+ set option2 [file join [testsDirectory] option.file2]
+ option read $option2
+} -returnCodes error -result {missing colon on line 2}
+
+
+test option-16.1 {ReadOptionFile} -body {
set option3 [makeFile {} option.file3]
set file [open $option3 w]
fconfigure $file -translation crlf
puts $file "*x7: true\n*x8: false"
close $file
option read $option3 userDefault
- set result [list [option get . x7 color] [option get . x8 color]]
+ list [option get . x7 color] [option get . x8 color]
+} -cleanup {
removeFile $option3
- set result
-} {true false}
+} -result {true false}
-catch {destroy .op1}
-catch {destroy .op2}
+deleteWindows
# cleanup
cleanupTests
return
+
+
+
diff --git a/tests/pack.test b/tests/pack.test
index edb9f18..eac1562 100644
--- a/tests/pack.test
+++ b/tests/pack.test
@@ -6,43 +6,15 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
+namespace import -force tcltest::test
-# Utility procedures:
-
-proc pack1 {args} {
- pack forget .pack.a .pack.b .pack.c .pack.d
- eval pack .pack.a $args
- pack .pack.b -expand yes -fill both
- update
- list [winfo geometry .pack.a] [winfo geometry .pack.b]
-}
-proc pack2 {args} {
- pack forget .pack.a .pack.b .pack.c .pack.d
- eval pack .pack.a $args
- update
- winfo geometry .pack.a
-}
-proc pack3 {args} {
- pack forget .pack.a .pack.b .pack.c .pack.d
- pack .pack.a -side top
- pack .pack.c -side left
- eval pack .pack.b $args
- update
- winfo geometry .pack.b
-}
-proc pack4 {option value} {
- pack forget .pack.a .pack.b .pack.c .pack.d
- pack .pack.a $option $value
- set i [pack info .pack.a]
- lindex $i [expr [lsearch -exact $i $option]+1]
-}
# Create some test windows.
-catch {destroy .pack}
+destroy .pack
toplevel .pack
wm geom .pack 300x200+0+0
wm minsize .pack 1 1
@@ -57,400 +29,767 @@ foreach i {a b c d} {
.pack.c config -width 80 -height 80
.pack.d config -width 40 -height 30
-test pack-1.1 {-side option} {
- pack1 -side top
-} {20x40+140+0 300x160+0+40}
-test pack-1.2 {-side option} {
- pack1 -side bottom
-} {20x40+140+160 300x160+0+0}
-test pack-1.3 {-side option} {
- pack1 -side left
-} {20x40+0+80 280x200+20+0}
-test pack-1.4 {-side option} {
- pack1 -side right
-} {20x40+280+80 280x200+0+0}
+test pack-1.1 {-side option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+140+0 300x160+0+40}
+test pack-1.2 {-side option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side bottom
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+140+160 300x160+0+0}
+test pack-1.3 {-side option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side left
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+0+80 280x200+20+0}
+test pack-1.4 {-side option} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+280+80 280x200+0+0}
-test pack-2.1 {x padding and filling} {
- pack1 -side right -padx 20
-} {20x40+260+80 240x200+0+0}
-test pack-2.1.1 {x padding and filling} {
- pack1 -side right -padx {10 30}
-} {20x40+250+80 240x200+0+0}
-test pack-2.1.2 {x padding and filling} {
- pack1 -side right -padx {35 5}
-} {20x40+275+80 240x200+0+0}
-test pack-2.2 {x padding and filling} {
- pack1 -side right -ipadx 20
-} {60x40+240+80 240x200+0+0}
-test pack-2.3 {x padding and filling} {
- pack1 -side right -ipadx 5 -padx 10
-} {30x40+260+80 250x200+0+0}
-test pack-2.4 {x padding and filling} {
- pack1 -side right -padx 20 -fill x
-} {20x40+260+80 240x200+0+0}
-test pack-2.4.1 {x padding and filling} {
- pack1 -side right -padx {9 31} -fill x
-} {20x40+249+80 240x200+0+0}
-test pack-2.5 {x padding and filling} {
- pack1 -side right -ipadx 20 -fill x
-} {60x40+240+80 240x200+0+0}
-test pack-2.6 {x padding and filling} {
- pack1 -side right -ipadx 5 -padx 10 -fill x
-} {30x40+260+80 250x200+0+0}
-test pack-2.6.1 {x padding and filling} {
- pack1 -side right -ipadx 5 -padx {5 15} -fill x
-} {30x40+255+80 250x200+0+0}
-test pack-2.7 {x padding and filling} {
- pack1 -side top -padx 20
-} {20x40+140+0 300x160+0+40}
-test pack-2.7.1 {x padding and filling} {
- pack1 -side top -padx {0 40}
-} {20x40+120+0 300x160+0+40}
-test pack-2.7.2 {x padding and filling} {
- pack1 -side top -padx {31 9}
-} {20x40+151+0 300x160+0+40}
-test pack-2.8 {x padding and filling} {
- pack1 -side top -ipadx 20
-} {60x40+120+0 300x160+0+40}
-test pack-2.9 {x padding and filling} {
- pack1 -side top -ipadx 5 -padx 10
-} {30x40+135+0 300x160+0+40}
-test pack-2.9.1 {x padding and filling} {
- pack1 -side top -ipadx 5 -padx {5 15}
-} {30x40+130+0 300x160+0+40}
-test pack-2.10 {x padding and filling} {
- pack1 -side top -padx 20 -fill x
-} {260x40+20+0 300x160+0+40}
-test pack-2.10.1 {x padding and filling} {
- pack1 -side top -padx {25 15} -fill x
-} {260x40+25+0 300x160+0+40}
-test pack-2.11 {x padding and filling} {
- pack1 -side top -ipadx 20 -fill x
-} {300x40+0+0 300x160+0+40}
-test pack-2.12 {x padding and filling} {
- pack1 -side top -ipadx 5 -padx 10 -fill x
-} {280x40+10+0 300x160+0+40}
-test pack-2.12a {x padding and filling} {
- pack1 -side top -ipadx 5 -padx {5 15} -fill x
-} {280x40+5+0 300x160+0+40}
-set pad [winfo pixels .pack 1c]
-test pack-2.13 {x padding and filling} {
+
+test pack-2.1 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -padx 20
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+260+80 240x200+0+0}
+test pack-2.2 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -padx {10 30}
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+250+80 240x200+0+0}
+test pack-2.3 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -padx {35 5}
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+275+80 240x200+0+0}
+test pack-2.4 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -ipadx 20
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {60x40+240+80 240x200+0+0}
+test pack-2.5 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -ipadx 5 -padx 10
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {30x40+260+80 250x200+0+0}
+test pack-2.6 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -padx 20 -fill x
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+260+80 240x200+0+0}
+test pack-2.7 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -padx {9 31} -fill x
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+249+80 240x200+0+0}
+test pack-2.8 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -ipadx 20 -fill x
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {60x40+240+80 240x200+0+0}
+test pack-2.9 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -ipadx 5 -padx 10 -fill x
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {30x40+260+80 250x200+0+0}
+test pack-2.10 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -ipadx 5 -padx {5 15} -fill x
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {30x40+255+80 250x200+0+0}
+test pack-2.11 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -padx 20
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+140+0 300x160+0+40}
+test pack-2.12 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -padx {0 40}
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+120+0 300x160+0+40}
+test pack-2.13 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -padx {31 9}
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+151+0 300x160+0+40}
+test pack-2.14 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 20
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {60x40+120+0 300x160+0+40}
+test pack-2.15 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 5 -padx 10
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {30x40+135+0 300x160+0+40}
+test pack-2.16 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 5 -padx {5 15}
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {30x40+130+0 300x160+0+40}
+test pack-2.17 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -padx 20 -fill x
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {260x40+20+0 300x160+0+40}
+test pack-2.18 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -padx {25 15} -fill x
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {260x40+25+0 300x160+0+40}
+test pack-2.19 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 20 -fill x
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {300x40+0+0 300x160+0+40}
+test pack-2.20 {x padding and filling} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 5 -padx 10 -fill x
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {280x40+10+0 300x160+0+40}
+test pack-2.21 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 5 -padx {5 15} -fill x
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {280x40+5+0 300x160+0+40}
+
+test pack-2.22 {x padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a -padx 1c
set x [pack info .pack.a]
- lindex $x [expr [lsearch -exact $x -padx]+1]
-} $pad
-test pack-2.14 {x padding and filling} {
+ set res1 [lindex $x [expr [lsearch -exact $x -padx]+1]]
+ set res2 [winfo pixels .pack 1c]
+ expr {$res1 eq $res2}
+} -result 1
+test pack-2.23 {x padding and filling} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a -ipadx 1c
set x [pack info .pack.a]
- lindex $x [expr [lsearch -exact $x -ipadx]+1]
-} $pad
+ set res1 [lindex $x [expr [lsearch -exact $x -ipadx]+1]]
+ set res2 [winfo pixels .pack 1c]
+ expr {$res1 eq $res2}
+} -result 1
-test pack-3.1 {y padding and filling} {
- pack1 -side right -pady 20
-} {20x40+280+80 280x200+0+0}
-test pack-3.1.1 {y padding and filling} {
- pack1 -side right -pady {5 35}
-} {20x40+280+65 280x200+0+0}
-test pack-3.1.2 {y padding and filling} {
- pack1 -side right -pady {40 0}
-} {20x40+280+100 280x200+0+0}
-test pack-3.2 {y padding and filling} {
- pack1 -side right -ipady 20
-} {20x80+280+60 280x200+0+0}
-test pack-3.3 {y padding and filling} {
- pack1 -side right -ipady 5 -pady 10
-} {20x50+280+75 280x200+0+0}
-test pack-3.3.1 {y padding and filling} {
- pack1 -side right -ipady 5 -pady {5 15}
-} {20x50+280+70 280x200+0+0}
-test pack-3.4 {y padding and filling} {
- pack1 -side right -pady 20 -fill y
-} {20x160+280+20 280x200+0+0}
-test pack-3.4.1 {y padding and filling} {
- pack1 -side right -pady {35 5} -fill y
-} {20x160+280+35 280x200+0+0}
-test pack-3.5 {y padding and filling} {
- pack1 -side right -ipady 20 -fill y
-} {20x200+280+0 280x200+0+0}
-test pack-3.6 {y padding and filling} {
- pack1 -side right -ipady 5 -pady 10 -fill y
-} {20x180+280+10 280x200+0+0}
-test pack-3.6.1 {y padding and filling} {
- pack1 -side right -ipady 5 -pady {0 20} -fill y
-} {20x180+280+0 280x200+0+0}
-test pack-3.7 {y padding and filling} {
- pack1 -side top -pady 20
-} {20x40+140+20 300x120+0+80}
-test pack-3.7.1 {y padding and filling} {
- pack1 -side top -pady {40 0}
-} {20x40+140+40 300x120+0+80}
-test pack-3.8 {y padding and filling} {
- pack1 -side top -ipady 20
-} {20x80+140+0 300x120+0+80}
-test pack-3.9 {y padding and filling} {
- pack1 -side top -ipady 5 -pady 10
-} {20x50+140+10 300x130+0+70}
-test pack-3.9.1 {y padding and filling} {
- pack1 -side top -ipady 5 -pady {3 17}
-} {20x50+140+3 300x130+0+70}
-test pack-3.10 {y padding and filling} {
- pack1 -side top -pady 20 -fill y
-} {20x40+140+20 300x120+0+80}
-test pack-3.10.1 {y padding and filling} {
- pack1 -side top -pady {39 1} -fill y
-} {20x40+140+39 300x120+0+80}
-test pack-3.11 {y padding and filling} {
- pack1 -side top -ipady 20 -fill y
-} {20x80+140+0 300x120+0+80}
-test pack-3.12 {y padding and filling} {
- pack1 -side top -ipady 5 -pady 10 -fill y
-} {20x50+140+10 300x130+0+70}
-test pack-3.12.1 {y padding and filling} {
- pack1 -side top -ipady 5 -pady {1 19} -fill y
-} {20x50+140+1 300x130+0+70}
-set pad [winfo pixels .pack 1c]
-test pack-3.13 {y padding and filling} {
+
+test pack-3.1 {y padding and filling} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -pady 20
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+280+80 280x200+0+0}
+test pack-3.2 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -pady {5 35}
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+280+65 280x200+0+0}
+test pack-3.3 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -pady {40 0}
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+280+100 280x200+0+0}
+test pack-3.4 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -ipady 20
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x80+280+60 280x200+0+0}
+test pack-3.5 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -ipady 5 -pady 10
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x50+280+75 280x200+0+0}
+test pack-3.6 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -ipady 5 -pady {5 15}
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x50+280+70 280x200+0+0}
+test pack-3.7 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -pady 20 -fill y
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x160+280+20 280x200+0+0}
+test pack-3.8 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -pady {35 5} -fill y
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x160+280+35 280x200+0+0}
+test pack-3.9 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -ipady 20 -fill y
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x200+280+0 280x200+0+0}
+test pack-3.10 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -ipady 5 -pady 10 -fill y
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x180+280+10 280x200+0+0}
+test pack-3.11 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side right -ipady 5 -pady {0 20} -fill y
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x180+280+0 280x200+0+0}
+test pack-3.12 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -pady 20
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+140+20 300x120+0+80}
+test pack-3.13 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -pady {40 0}
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+140+40 300x120+0+80}
+test pack-3.14 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipady 20
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x80+140+0 300x120+0+80}
+test pack-3.15 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipady 5 -pady 10
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x50+140+10 300x130+0+70}
+test pack-3.16 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipady 5 -pady {3 17}
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x50+140+3 300x130+0+70}
+test pack-3.17 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -pady 20 -fill y
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+140+20 300x120+0+80}
+test pack-3.18 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -pady {39 1} -fill y
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x40+140+39 300x120+0+80}
+test pack-3.19 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipady 20 -fill y
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x80+140+0 300x120+0+80}
+test pack-3.20 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipady 5 -pady 10 -fill y
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x50+140+10 300x130+0+70}
+test pack-3.21 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipady 5 -pady {1 19} -fill y
+ pack .pack.b -expand yes -fill both
+ update
+ list [winfo geometry .pack.a] [winfo geometry .pack.b]
+} -result {20x50+140+1 300x130+0+70}
+
+test pack-3.22 {y padding and filling} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a -pady 1c
set x [pack info .pack.a]
- lindex $x [expr [lsearch -exact $x -pady]+1]
-} $pad
-test pack-3.14 {y padding and filling} {
+ set res1 [lindex $x [expr [lsearch -exact $x -pady]+1]]
+ set res2 [winfo pixels .pack 1c]
+ expr {$res1 eq $res2}
+} -result 1
+test pack-3.23 {y padding and filling} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a -ipady 1c
set x [pack info .pack.a]
- lindex $x [expr [lsearch -exact $x -ipady]+1]
-} $pad
+ set res1 [lindex $x [expr [lsearch -exact $x -ipady]+1]]
+ set res2 [winfo pixels .pack 1c]
+ expr {$res1 eq $res2}
+} -result 1
+
+
+test pack-4.1 {anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor n
+ update
+ winfo geometry .pack.a
+} -result {30x70+135+20}
+test pack-4.2 {anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor ne
+ update
+ winfo geometry .pack.a
+} -result {30x70+260+20}
+test pack-4.3 {anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor e
+ update
+ winfo geometry .pack.a
+} -result {30x70+260+65}
+test pack-4.4 {anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor se
+ update
+ winfo geometry .pack.a
+} -result {30x70+260+110}
+test pack-4.5 {anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor s
+ update
+ winfo geometry .pack.a
+} -result {30x70+135+110}
+test pack-4.6 {anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor sw
+ update
+ winfo geometry .pack.a
+} -result {30x70+10+110}
+test pack-4.7 {anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor w
+ update
+ winfo geometry .pack.a
+} -result {30x70+10+65}
+test pack-4.8 {anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor nw
+ update
+ winfo geometry .pack.a
+} -result {30x70+10+20}
+test pack-4.9 {anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor center
+ update
+ winfo geometry .pack.a
+} -result {30x70+135+65}
-test pack-4.1 {anchors} {
- pack2 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor n
-} {30x70+135+20}
-test pack-4.2 {anchors} {
- pack2 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor ne
-} {30x70+260+20}
-test pack-4.3 {anchors} {
- pack2 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor e
-} {30x70+260+65}
-test pack-4.4 {anchors} {
- pack2 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor se
-} {30x70+260+110}
-test pack-4.5 {anchors} {
- pack2 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor s
-} {30x70+135+110}
-test pack-4.6 {anchors} {
- pack2 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor sw
-} {30x70+10+110}
-test pack-4.7 {anchors} {
- pack2 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor w
-} {30x70+10+65}
-test pack-4.8 {anchors} {
- pack2 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor nw
-} {30x70+10+20}
-test pack-4.9 {anchors} {
- pack2 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor center
-} {30x70+135+65}
# Repeat above tests, but with a frame that isn't at (0,0), so that
# we can be sure that the frame offset is being added in correctly.
-test pack-5.1 {more anchors} {
- pack3 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor n
-} {60x60+160+60}
-test pack-5.2 {more anchors} {
- pack3 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor ne
-} {60x60+230+60}
-test pack-5.3 {more anchors} {
- pack3 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor e
-} {60x60+230+90}
-test pack-5.4 {more anchors} {
- pack3 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor se
-} {60x60+230+120}
-test pack-5.5 {more anchors} {
- pack3 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor s
-} {60x60+160+120}
-test pack-5.6 {more anchors} {
- pack3 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor sw
-} {60x60+90+120}
-test pack-5.7 {more anchors} {
- pack3 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor w
-} {60x60+90+90}
-test pack-5.8 {more anchors} {
- pack3 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor nw
-} {60x60+90+60}
-test pack-5.9 {more anchors} {
- pack3 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor center
-} {60x60+160+90}
+test pack-5.1 {more anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top
+ pack .pack.c -side left
+ pack .pack.b -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor n
+ update
+ winfo geometry .pack.b
+} -result {60x60+160+60}
+test pack-5.2 {more anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top
+ pack .pack.c -side left
+ pack .pack.b -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor ne
+ update
+ winfo geometry .pack.b
+} -result {60x60+230+60}
+test pack-5.3 {more anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top
+ pack .pack.c -side left
+ pack .pack.b -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor e
+ update
+ winfo geometry .pack.b
+} -result {60x60+230+90}
+test pack-5.4 {more anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top
+ pack .pack.c -side left
+ pack .pack.b -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor se
+ update
+ winfo geometry .pack.b
+} -result {60x60+230+120}
+test pack-5.5 {more anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top
+ pack .pack.c -side left
+ pack .pack.b -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor s
+ update
+ winfo geometry .pack.b
+} -result {60x60+160+120}
+test pack-5.6 {more anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top
+ pack .pack.c -side left
+ pack .pack.b -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor sw
+ update
+ winfo geometry .pack.b
+} -result {60x60+90+120}
+test pack-5.7 {more anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top
+ pack .pack.c -side left
+ pack .pack.b -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor w
+ update
+ winfo geometry .pack.b
+} -result {60x60+90+90}
+test pack-5.8 {more anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top
+ pack .pack.c -side left
+ pack .pack.b -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor nw
+ update
+ winfo geometry .pack.b
+} -result {60x60+90+60}
+test pack-5.9 {more anchors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side top
+ pack .pack.c -side left
+ pack .pack.b -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor center
+ update
+ winfo geometry .pack.b
+} -result {60x60+160+90}
+
-test pack-6.1 {-expand option} {
+test pack-6.1 {-expand option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a .pack.b .pack.c .pack.d -side left
update
list [winfo geometry .pack.a] [winfo geometry .pack.b] \
- [winfo geometry .pack.c] [winfo geometry .pack.d]
-} {20x40+0+80 50x30+20+85 80x80+70+60 40x30+150+85}
-test pack-6.2 {-expand option} {
+ [winfo geometry .pack.c] [winfo geometry .pack.d]
+} -result {20x40+0+80 50x30+20+85 80x80+70+60 40x30+150+85}
+test pack-6.2 {-expand option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a -side left -expand yes
pack .pack.b -side left
pack .pack.c .pack.d -side left -expand 1
update
list [winfo geometry .pack.a] [winfo geometry .pack.b] \
- [winfo geometry .pack.c] [winfo geometry .pack.d]
-} {20x40+18+80 50x30+56+85 80x80+124+60 40x30+241+85}
-test pack-6.3 {-expand option} {
+ [winfo geometry .pack.c] [winfo geometry .pack.d]
+} -result {20x40+18+80 50x30+56+85 80x80+124+60 40x30+241+85}
+test pack-6.3 {-expand option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a .pack.b .pack.c .pack.d -side top
update
list [winfo geometry .pack.a] [winfo geometry .pack.b] \
- [winfo geometry .pack.c] [winfo geometry .pack.d]
-} {20x40+140+0 50x30+125+40 80x80+110+70 40x30+130+150}
-test pack-6.4 {-expand option} {
+ [winfo geometry .pack.c] [winfo geometry .pack.d]
+} -result {20x40+140+0 50x30+125+40 80x80+110+70 40x30+130+150}
+test pack-6.4 {-expand option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a -side top -expand yes
pack .pack.b -side top
pack .pack.c .pack.d -side top -expand 1
update
list [winfo geometry .pack.a] [winfo geometry .pack.b] \
- [winfo geometry .pack.c] [winfo geometry .pack.d]
-} {20x40+140+3 50x30+125+46 80x80+110+79 40x30+130+166}
-test pack-6.5 {-expand option} {
+ [winfo geometry .pack.c] [winfo geometry .pack.d]
+} -result {20x40+140+3 50x30+125+46 80x80+110+79 40x30+130+166}
+test pack-6.5 {-expand option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a .pack.b .pack.c .pack.d -side right
update
list [winfo geometry .pack.a] [winfo geometry .pack.b] \
- [winfo geometry .pack.c] [winfo geometry .pack.d]
-} {20x40+280+80 50x30+230+85 80x80+150+60 40x30+110+85}
-test pack-6.6 {-expand option} {
+ [winfo geometry .pack.c] [winfo geometry .pack.d]
+} -result {20x40+280+80 50x30+230+85 80x80+150+60 40x30+110+85}
+test pack-6.6 {-expand option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a -side right -expand yes
pack .pack.b -side right
pack .pack.c .pack.d -side right -expand 1
update
list [winfo geometry .pack.a] [winfo geometry .pack.b] \
- [winfo geometry .pack.c] [winfo geometry .pack.d]
-} {20x40+262+80 50x30+194+85 80x80+95+60 40x30+18+85}
-test pack-6.7 {-expand option} {
+ [winfo geometry .pack.c] [winfo geometry .pack.d]
+} -result {20x40+262+80 50x30+194+85 80x80+95+60 40x30+18+85}
+test pack-6.7 {-expand option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a .pack.b .pack.c .pack.d -side bottom
update
list [winfo geometry .pack.a] [winfo geometry .pack.b] \
- [winfo geometry .pack.c] [winfo geometry .pack.d]
-} {20x40+140+160 50x30+125+130 80x80+110+50 40x30+130+20}
-test pack-6.8 {-expand option} {
+ [winfo geometry .pack.c] [winfo geometry .pack.d]
+} -result {20x40+140+160 50x30+125+130 80x80+110+50 40x30+130+20}
+test pack-6.8 {-expand option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a -side bottom -expand yes
pack .pack.b -side bottom
pack .pack.c .pack.d -side bottom -expand 1
update
list [winfo geometry .pack.a] [winfo geometry .pack.b] \
- [winfo geometry .pack.c] [winfo geometry .pack.d]
-} {20x40+140+157 50x30+125+124 80x80+110+40 40x30+130+3}
-test pack-6.9 {-expand option} {
+ [winfo geometry .pack.c] [winfo geometry .pack.d]
+} -result {20x40+140+157 50x30+125+124 80x80+110+40 40x30+130+3}
+test pack-6.9 {-expand option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a -side bottom -expand yes -fill both
pack .pack.b -side right
pack .pack.c -side top -expand 1 -fill both
pack .pack.d -side left
update
list [winfo geometry .pack.a] [winfo geometry .pack.b] \
- [winfo geometry .pack.c] [winfo geometry .pack.d]
-} {300x65+0+135 50x30+250+52 250x105+0+0 40x30+0+105}
-test pack-6.10 {-expand option} {
+ [winfo geometry .pack.c] [winfo geometry .pack.d]
+} -result {300x65+0+135 50x30+250+52 250x105+0+0 40x30+0+105}
+test pack-6.10 {-expand option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a -side left -expand yes -fill both
pack .pack.b -side top
pack .pack.c -side right -expand 1 -fill both
pack .pack.d -side bottom
update
list [winfo geometry .pack.a] [winfo geometry .pack.b] \
- [winfo geometry .pack.c] [winfo geometry .pack.d]
-} {100x200+0+0 50x30+175+0 160x170+140+30 40x30+100+170}
-test pack-6.11 {-expand option} {
+ [winfo geometry .pack.c] [winfo geometry .pack.d]
+} -result {100x200+0+0 50x30+175+0 160x170+140+30 40x30+100+170}
+test pack-6.11 {-expand option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a -side left -expand yes -fill both
pack .pack.b -side top -expand yes -fill both
pack .pack.c -side right -expand 1 -fill both
pack .pack.d -side bottom -expand yes -fill both
update
list [winfo geometry .pack.a] [winfo geometry .pack.b] \
- [winfo geometry .pack.c] [winfo geometry .pack.d]
-} {100x200+0+0 200x100+100+0 160x100+140+100 40x100+100+100}
-catch {destroy .pack2}
-toplevel .pack2 -height 400 -width 400
-wm geometry .pack2 +0+0
-pack propagate .pack2 0
-pack forget .pack2.a .pack2.b .pack2.c .pack2.d
-foreach i {w1 w2 w3} {
- frame .pack2.$i -width 30 -height 30 -bd 2 -relief raised
- label .pack2.$i.l -text $i
- place .pack2.$i.l -relwidth 1.0 -relheight 1.0
-}
-test pack-6.12 {-expand option} {
+ [winfo geometry .pack.c] [winfo geometry .pack.d]
+} -result {100x200+0+0 200x100+100+0 160x100+140+100 40x100+100+100}
+
+test pack-6.12 {-expand option} -setup {
+ toplevel .pack2 -height 400 -width 400
+ wm geometry .pack2 +0+0
+ pack propagate .pack2 0
+ foreach i {w1 w2 w3} {
+ frame .pack2.$i -width 30 -height 30 -bd 2 -relief raised
+ label .pack2.$i.l -text $i
+ place .pack2.$i.l -relwidth 1.0 -relheight 1.0
+ }
+} -body {
pack .pack2.w1 .pack2.w2 .pack2.w3 -padx 5 -ipadx 4 -pady 2 -ipady 6 -expand 1 -side left
update
list [winfo geometry .pack2.w1] [winfo geometry .pack2.w2] [winfo geometry .pack2.w3]
-} {38x42+47+179 38x42+180+179 38x42+314+179}
-test pack-6.13 {-expand option} {
- pack forget .pack2.w1 .pack2.w2 .pack2.w3
+} -cleanup {
+ destroy .pack2
+} -result {38x42+47+179 38x42+180+179 38x42+314+179}
+test pack-6.13 {-expand option} -setup {
+ toplevel .pack2 -height 400 -width 400
+ wm geometry .pack2 +0+0
+ pack propagate .pack2 0
+ foreach i {w1 w2 w3} {
+ frame .pack2.$i -width 30 -height 30 -bd 2 -relief raised
+ label .pack2.$i.l -text $i
+ place .pack2.$i.l -relwidth 1.0 -relheight 1.0
+ }
+} -body {
pack .pack2.w1 .pack2.w2 .pack2.w3 -padx 5 -ipadx 4 -pady 2 \
- -ipady 6 -expand 1 -side top
+ -ipady 6 -expand 1 -side top
update
list [winfo geometry .pack2.w1] [winfo geometry .pack2.w2] [winfo geometry .pack2.w3]
-} {38x42+181+45 38x42+181+178 38x42+181+312}
-catch {destroy .pack2}
+} -cleanup {
+ destroy .pack2
+} -result {38x42+181+45 38x42+181+178 38x42+181+312}
+
wm geometry .pack {}
-test pack-7.1 {requesting size for parent} {
+test pack-7.1 {requesting size for parent} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a .pack.b .pack.c .pack.d -side left -padx 5 -pady 10
update
list [winfo reqwidth .pack] [winfo reqheight .pack]
-} {230 100}
-test pack-7.2 {requesting size for parent} {
+} -result {230 100}
+test pack-7.2 {requesting size for parent} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a .pack.b .pack.c .pack.d -side top -padx 5 -pady 10
update
list [winfo reqwidth .pack] [winfo reqheight .pack]
-} {90 260}
-test pack-7.3 {requesting size for parent} {
+} -result {90 260}
+test pack-7.3 {requesting size for parent} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a .pack.b .pack.c .pack.d -side right -padx 5 -pady 10
update
list [winfo reqwidth .pack] [winfo reqheight .pack]
-} {230 100}
-test pack-7.4 {requesting size for parent} {
+} -result {230 100}
+test pack-7.4 {requesting size for parent} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a .pack.b .pack.c .pack.d -side bottom -padx 5 -pady 10
update
list [winfo reqwidth .pack] [winfo reqheight .pack]
-} {90 260}
-test pack-7.5 {requesting size for parent} {
+} -result {90 260}
+test pack-7.5 {requesting size for parent} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a -side top -padx 5 -pady 10
pack .pack.b -side right -padx 5 -pady 10
pack .pack.c -side bottom -padx 5 -pady 10
pack .pack.d -side left -padx 5 -pady 10
update
list [winfo reqwidth .pack] [winfo reqheight .pack]
-} {150 210}
-test pack-7.6 {requesting size for parent} {
+} -result {150 210}
+test pack-7.6 {requesting size for parent} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a -side top
pack .pack.c -side left
pack .pack.d -side bottom
update
list [winfo reqwidth .pack] [winfo reqheight .pack]
-} {120 120}
-test pack-7.7 {requesting size for parent} {
+} -result {120 120}
+test pack-7.7 {requesting size for parent} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a -side right
pack .pack.c -side bottom
pack .pack.d -side top
update
list [winfo reqwidth .pack] [winfo reqheight .pack]
-} {100 110}
+} -result {100 110}
# For the tests below, create a couple of "pad" windows to shrink
@@ -466,363 +805,496 @@ pack .pack.right -side right
pack .pack.bottom -side bottom
pack .pack.a .pack.b .pack.c -side top
update
-test pack-8.1 {insufficient space} {
+test pack-8.1 {insufficient space} -body {
list [winfo geometry .pack.a] [winfo ismapped .pack.a] \
- [winfo geometry .pack.b] [winfo ismapped .pack.b] \
- [winfo geometry .pack.c] [winfo ismapped .pack.c]
-} {20x40+30+0 1 50x30+15+40 1 80x80+0+70 1}
+ [winfo geometry .pack.b] [winfo ismapped .pack.b] \
+ [winfo geometry .pack.c] [winfo ismapped .pack.c]
+} -result {20x40+30+0 1 50x30+15+40 1 80x80+0+70 1}
wm geom .pack 270x250
update
-test pack-8.2 {insufficient space} {
+test pack-8.2 {insufficient space} -body {
list [winfo geometry .pack.a] [winfo ismapped .pack.a] \
- [winfo geometry .pack.b] [winfo ismapped .pack.b] \
- [winfo geometry .pack.c] [winfo ismapped .pack.c]
-} {20x40+25+0 1 50x30+10+40 1 70x30+0+70 1}
+ [winfo geometry .pack.b] [winfo ismapped .pack.b] \
+ [winfo geometry .pack.c] [winfo ismapped .pack.c]
+} -result {20x40+25+0 1 50x30+10+40 1 70x30+0+70 1}
wm geom .pack 240x220
update
-test pack-8.3 {insufficient space} {
+test pack-8.3 {insufficient space} -body {
list [winfo geometry .pack.a] [winfo ismapped .pack.a] \
- [winfo geometry .pack.b] [winfo ismapped .pack.b] \
- [winfo geometry .pack.c] [winfo ismapped .pack.c]
-} {20x40+10+0 1 40x30+0+40 1 70x30+0+70 0}
+ [winfo geometry .pack.b] [winfo ismapped .pack.b] \
+ [winfo geometry .pack.c] [winfo ismapped .pack.c]
+} -result {20x40+10+0 1 40x30+0+40 1 70x30+0+70 0}
wm geom .pack 350x350
update
-test pack-8.4 {insufficient space} {
+test pack-8.4 {insufficient space} -body {
list [winfo geometry .pack.a] [winfo ismapped .pack.a] \
- [winfo geometry .pack.b] [winfo ismapped .pack.b] \
- [winfo geometry .pack.c] [winfo ismapped .pack.c]
-} {20x40+65+0 1 50x30+50+40 1 80x80+35+70 1}
+ [winfo geometry .pack.b] [winfo ismapped .pack.b] \
+ [winfo geometry .pack.c] [winfo ismapped .pack.c]
+} -result {20x40+65+0 1 50x30+50+40 1 80x80+35+70 1}
wm geom .pack {}
pack .pack.a -side left
pack .pack.b -side right
pack .pack.c -side left
update
-test pack-8.5 {insufficient space} {
+test pack-8.5 {insufficient space} -body {
list [winfo geometry .pack.a] [winfo ismapped .pack.a] \
- [winfo geometry .pack.b] [winfo ismapped .pack.b] \
- [winfo geometry .pack.c] [winfo ismapped .pack.c]
-} {20x40+0+20 1 50x30+100+25 1 80x80+20+0 1}
+ [winfo geometry .pack.b] [winfo ismapped .pack.b] \
+ [winfo geometry .pack.c] [winfo ismapped .pack.c]
+} -result {20x40+0+20 1 50x30+100+25 1 80x80+20+0 1}
wm geom .pack 320x180
update
-test pack-8.6 {insufficient space} {
+test pack-8.6 {insufficient space} -body {
list [winfo geometry .pack.a] [winfo ismapped .pack.a] \
- [winfo geometry .pack.b] [winfo ismapped .pack.b] \
- [winfo geometry .pack.c] [winfo ismapped .pack.c]
-} {20x30+0+0 1 50x30+70+0 1 50x30+20+0 1}
+ [winfo geometry .pack.b] [winfo ismapped .pack.b] \
+ [winfo geometry .pack.c] [winfo ismapped .pack.c]
+} -result {20x30+0+0 1 50x30+70+0 1 50x30+20+0 1}
wm geom .pack 250x180
update
-test pack-8.7 {insufficient space} {
+test pack-8.7 {insufficient space} -body {
list [winfo geometry .pack.a] [winfo ismapped .pack.a] \
- [winfo geometry .pack.b] [winfo ismapped .pack.b] \
- [winfo geometry .pack.c] [winfo ismapped .pack.c]
-} {20x30+0+0 1 30x30+20+0 1 50x30+20+0 0}
+ [winfo geometry .pack.b] [winfo ismapped .pack.b] \
+ [winfo geometry .pack.c] [winfo ismapped .pack.c]
+} -result {20x30+0+0 1 30x30+20+0 1 50x30+20+0 0}
pack forget .pack.b
update
-test pack-8.8 {insufficient space} {
+test pack-8.8 {insufficient space} -body {
list [winfo geometry .pack.a] [winfo ismapped .pack.a] \
- [winfo geometry .pack.b] [winfo ismapped .pack.b] \
- [winfo geometry .pack.c] [winfo ismapped .pack.c]
-} {20x30+0+0 1 30x30+20+0 0 30x30+20+0 1}
+ [winfo geometry .pack.b] [winfo ismapped .pack.b] \
+ [winfo geometry .pack.c] [winfo ismapped .pack.c]
+} -result {20x30+0+0 1 30x30+20+0 0 30x30+20+0 1}
pack .pack.b -side right -after .pack.a
wm geom .pack {}
update
-test pack-8.9 {insufficient space} {
+test pack-8.9 {insufficient space} -body {
list [winfo geometry .pack.a] [winfo ismapped .pack.a] \
- [winfo geometry .pack.b] [winfo ismapped .pack.b] \
- [winfo geometry .pack.c] [winfo ismapped .pack.c]
-} {20x40+0+20 1 50x30+100+25 1 80x80+20+0 1}
+ [winfo geometry .pack.b] [winfo ismapped .pack.b] \
+ [winfo geometry .pack.c] [winfo ismapped .pack.c]
+} -result {20x40+0+20 1 50x30+100+25 1 80x80+20+0 1}
pack forget .pack.right .pack.bottom
-test pack-9.1 {window ordering} {
+
+test pack-9.1 {window ordering} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a .pack.b .pack.c .pack.d -side top
pack .pack.a -after .pack.b
pack slaves .pack
-} {.pack.b .pack.a .pack.c .pack.d}
-test pack-9.2 {window ordering} {
+} -result {.pack.b .pack.a .pack.c .pack.d}
+test pack-9.2 {window ordering} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a .pack.b .pack.c .pack.d -side top
pack .pack.a -after .pack.a
pack slaves .pack
-} {.pack.a .pack.b .pack.c .pack.d}
-test pack-9.3 {window ordering} {
+} -result {.pack.a .pack.b .pack.c .pack.d}
+test pack-9.3 {window ordering} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a .pack.b .pack.c .pack.d -side top
pack .pack.a -before .pack.d
pack slaves .pack
-} {.pack.b .pack.c .pack.a .pack.d}
-test pack-9.4 {window ordering} {
+} -result {.pack.b .pack.c .pack.a .pack.d}
+test pack-9.4 {window ordering} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a .pack.b .pack.c .pack.d -side top
pack .pack.d -before .pack.a
pack slaves .pack
-} {.pack.d .pack.a .pack.b .pack.c}
-test pack-9.5 {window ordering} {
+} -result {.pack.d .pack.a .pack.b .pack.c}
+test pack-9.5 {window ordering} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a .pack.b .pack.c .pack.d -side top
pack propagate .pack.c 0
pack .pack.a -in .pack.c
list [pack slaves .pack] [pack slaves .pack.c]
-} {{.pack.b .pack.c .pack.d} .pack.a}
-test pack-9.6 {window ordering} {
+} -result {{.pack.b .pack.c .pack.d} .pack.a}
+test pack-9.6 {window ordering} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a .pack.b .pack.c .pack.d -side top
pack .pack.a -in .pack
pack slaves .pack
-} {.pack.b .pack.c .pack.d .pack.a}
-test pack-9.7 {window ordering} {
+} -result {.pack.b .pack.c .pack.d .pack.a}
+test pack-9.7 {window ordering} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a .pack.b .pack.c .pack.d -side top
pack .pack.a -padx 0
pack slaves .pack
-} {.pack.a .pack.b .pack.c .pack.d}
-test pack-9.8 {window ordering} {
+} -result {.pack.a .pack.b .pack.c .pack.d}
+test pack-9.8 {window ordering} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a .pack.b .pack.c
pack .pack.d
pack slaves .pack
-} {.pack.a .pack.b .pack.c .pack.d}
-test pack-9.9 {window ordering} {
+} -result {.pack.a .pack.b .pack.c .pack.d}
+test pack-9.9 {window ordering} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a .pack.b .pack.c .pack.d
pack .pack.b .pack.d .pack.c -before .pack.a
pack slaves .pack
-} {.pack.b .pack.d .pack.c .pack.a}
-test pack-9.10 {window ordering} {
+} -result {.pack.b .pack.d .pack.c .pack.a}
+test pack-9.10 {window ordering} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a .pack.b .pack.c .pack.d
pack .pack.a .pack.c .pack.d .pack.b -after .pack.a
pack slaves .pack
-} {.pack.a .pack.c .pack.d .pack.b}
+} -result {.pack.a .pack.c .pack.d .pack.b}
+
-test pack-10.1 {retaining/clearing configuration state} {
+test pack-10.1 {retaining/clearing configuration state} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a -side bottom -anchor n -padx 1 -pady 2 -ipadx 3 -ipady 4 \
- -fill both -expand 1
+ -fill both -expand 1
pack forget .pack.a
pack .pack.a
pack info .pack.a
-} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top}
-test pack-10.2 {retaining/clearing configuration state} {
+} -result {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top}
+test pack-10.2 {retaining/clearing configuration state} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a -side bottom -anchor n -padx 1 -pady 2 -ipadx 3 -ipady 4 \
- -fill both -expand 1
+ -fill both -expand 1
pack .pack.a -pady 14
pack info .pack.a
-} {-in .pack -anchor n -expand 1 -fill both -ipadx 3 -ipady 4 -padx 1 -pady 14 -side bottom}
-test pack-10.3 {bad -in window does not change master} {
+} -result {-in .pack -anchor n -expand 1 -fill both -ipadx 3 -ipady 4 -padx 1 -pady 14 -side bottom}
+test pack-10.3 {bad -in window does not change master} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
- list [winfo manager .pack.a] \
- [catch {pack .pack.a -in .pack.a} err] $err \
- [winfo manager .pack.a]
-} {{} 1 {can't pack .pack.a inside itself} {}}
+} -body {
+ set result [list [winfo manager .pack.a]]
+ catch {pack .pack.a -in .pack.a}
+ lappend result [winfo manager .pack.a]
+} -result {{} {}}
+test pack-10.4 {bad -in window does not change master} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ winfo manager .pack.a
+ pack .pack.a -in .pack.a
+} -returnCodes error -result {can't pack .pack.a inside itself}
-test pack-11.1 {info option} {
- pack4 -in .pack
-} .pack
-test pack-11.2 {info option} {
- pack4 -anchor n
-} n
-test pack-11.3 {info option} {
- pack4 -anchor sw
-} sw
-test pack-11.4 {info option} {
- pack4 -expand yes
-} 1
-test pack-11.5 {info option} {
- pack4 -expand no
-} 0
-test pack-11.6 {info option} {
- pack4 -fill x
-} x
-test pack-11.7 {info option} {
- pack4 -fill y
-} y
-test pack-11.8 {info option} {
- pack4 -fill both
-} both
-test pack-11.9 {info option} {
- pack4 -fill none
-} none
-test pack-11.10 {info option} {
- pack4 -ipadx 14
-} 14
-test pack-11.11 {info option} {
- pack4 -ipady 22
-} 22
-test pack-11.12 {info option} {
- pack4 -padx 2
-} 2
-test pack-11.12.1 {info option} {
- pack4 -padx {2 9}
-} {2 9}
-test pack-11.13 {info option} {
- pack4 -pady 3
-} 3
-test pack-11.13.1 {info option} {
- pack4 -pady {3 11}
-} {3 11}
-test pack-11.14 {info option} {
- pack4 -side top
-} top
-test pack-11.15 {info option} {
- pack4 -side bottom
-} bottom
-test pack-11.16 {info option} {
- pack4 -side left
-} left
-test pack-11.17 {info option} {
- pack4 -side right
-} right
-test pack-12.1 {command options and errors} {
- list [catch {pack} msg] $msg
-} {1 {wrong # args: should be "pack option arg ?arg ...?"}}
-test pack-12.2 {command options and errors} {
- list [catch {pack foo} msg] $msg
-} {1 {wrong # args: should be "pack option arg ?arg ...?"}}
-test pack-12.3 {command options and errors} {
- list [catch {pack configure x} msg] $msg
-} {1 {bad argument "x": must be name of window}}
-test pack-12.4 {command options and errors} {
- pack forget .pack.a .pack.b .pack.c .pack.d
- pack configure .pack.b .pack.c
- pack slaves .pack
-} {.pack.b .pack.c}
-test pack-12.5 {command options and errors} {
- pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .foo} msg] $msg
-} {1 {bad window path name ".foo"}}
-test pack-12.6 {command options and errors} {
- pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack} msg] $msg
-} {1 {can't pack ".pack": it's a top-level window}}
-test pack-12.7 {command options and errors} {
- pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a -after .foo} msg] $msg
-} {1 {bad window path name ".foo"}}
-test pack-12.8 {command options and errors} {
+test pack-11.1 {info option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a -after .pack.b} msg] $msg
-} {1 {window ".pack.b" isn't packed}}
-test pack-12.9 {command options and errors} {
- pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a -anchor gorp} msg] $msg
-} {1 {bad anchor "gorp": must be n, ne, e, se, s, sw, w, nw, or center}}
-test pack-12.10 {command options and errors} {
- pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a -before gorp} msg] $msg
-} {1 {bad window path name "gorp"}}
-test pack-12.11 {command options and errors} {
- pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a -before .pack.b} msg] $msg
-} {1 {window ".pack.b" isn't packed}}
-test pack-12.12 {command options and errors} {
- pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a -expand "who cares?"} msg] $msg
-} {1 {expected boolean value but got "who cares?"}}
-test pack-12.13 {command options and errors} {
+} -body {
+ pack .pack.a -in .pack
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -in]+1]
+} -result .pack
+test pack-11.2 {info option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a -fill z} msg] $msg
-} {1 {bad fill style "z": must be none, x, y, or both}}
-test pack-12.14 {command options and errors} {
+} -body {
+ pack .pack.a -anchor n
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -anchor]+1]
+} -result n
+test pack-11.3 {info option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a -in z} msg] $msg
-} {1 {bad window path name "z"}}
-set pad [winfo pixels .pack 1c]
-test pack-12.15 {command options and errors} {
+} -body {
+ pack .pack.a -anchor sw
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -anchor]+1]
+} -result sw
+test pack-11.4 {info option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a -padx abc} msg] $msg
-} {1 {bad pad value "abc": must be positive screen distance}}
-test pack-12.15.1 {command options and errors} {
+} -body {
+ pack .pack.a -expand yes
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -expand]+1]
+} -result 1
+test pack-11.5 {info option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a -padx {5 abc}} msg] $msg
-} {1 {bad 2nd pad value "abc": must be positive screen distance}}
-test pack-12.16 {command options and errors} {
+} -body {
+ pack .pack.a -expand no
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -expand]+1]
+} -result 0
+test pack-11.6 {info option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a -padx -1} msg] $msg
-} {1 {bad pad value "-1": must be positive screen distance}}
-test pack-12.16.1 {command options and errors} {
+} -body {
+ pack .pack.a -fill x
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -fill]+1]
+} -result x
+test pack-11.7 {info option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a -padx {5 -1}} msg] $msg
-} {1 {bad 2nd pad value "-1": must be positive screen distance}}
-test pack-12.17 {command options and errors} {
+} -body {
+ pack .pack.a -fill y
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -fill]+1]
+} -result y
+test pack-11.8 {info option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a -pady abc} msg] $msg
-} {1 {bad pad value "abc": must be positive screen distance}}
-test pack-12.17.1 {command options and errors} {
+} -body {
+ pack .pack.a -fill both
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -fill]+1]
+} -result both
+test pack-11.9 {info option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a -pady {0 abc}} msg] $msg
-} {1 {bad 2nd pad value "abc": must be positive screen distance}}
-test pack-12.18 {command options and errors} {
+} -body {
+ pack .pack.a -fill none
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -fill]+1]
+} -result none
+test pack-11.10 {info option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a -pady -1} msg] $msg
-} {1 {bad pad value "-1": must be positive screen distance}}
-test pack-12.18.1 {command options and errors} {
+} -body {
+ pack .pack.a -ipadx 14
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -ipadx]+1]
+} -result 14
+test pack-11.11 {info option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a -pady {0 -1}} msg] $msg
-} {1 {bad 2nd pad value "-1": must be positive screen distance}}
-test pack-12.19 {command options and errors} {
+} -body {
+ pack .pack.a -ipady 22
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -ipady]+1]
+} -result 22
+test pack-11.12 {info option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a -ipadx abc} msg] $msg
-} {1 {bad ipadx value "abc": must be positive screen distance}}
-test pack-12.20 {command options and errors} {
+} -body {
+ pack .pack.a -padx 2
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -padx]+1]
+} -result 2
+test pack-11.13 {info option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a -ipadx -1} msg] $msg
-} {1 {bad ipadx value "-1": must be positive screen distance}}
-test pack-12.20.1 {command options and errors} {
+} -body {
+ pack .pack.a -padx {2 9}
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -padx]+1]
+} -result {2 9}
+test pack-11.14 {info option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a -ipadx {5 5}} msg] $msg
-} {1 {bad ipadx value "5 5": must be positive screen distance}}
-test pack-12.21 {command options and errors} {
+} -body {
+ pack .pack.a -pady 3
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -pady]+1]
+} -result 3
+test pack-11.15 {info option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a -ipady abc} msg] $msg
-} {1 {bad ipady value "abc": must be positive screen distance}}
-test pack-12.22 {command options and errors} {
+} -body {
+ pack .pack.a -pady {3 11}
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -pady]+1]
+} -result {3 11}
+test pack-11.16 {info option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a -ipady -1} msg] $msg
-} {1 {bad ipady value "-1": must be positive screen distance}}
-test pack-12.22.1 {command options and errors} {
+} -body {
+ pack .pack.a -side top
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -side]+1]
+} -result top
+test pack-11.17 {info option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a -ipady {5 5}} msg] $msg
-} {1 {bad ipady value "5 5": must be positive screen distance}}
-test pack-12.23 {command options and errors} {
+} -body {
+ pack .pack.a -side bottom
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -side]+1]
+} -result bottom
+test pack-11.18 {info option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a -side bac} msg] $msg
-} {1 {bad side "bac": must be top, bottom, left, or right}}
-test pack-12.24 {command options and errors} {
+} -body {
+ pack .pack.a -side left
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -side]+1]
+} -result left
+test pack-11.19 {info option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a -lousy bac} msg] $msg
-} {1 {bad option "-lousy": must be -after, -anchor, -before, -expand, -fill, -in, -ipadx, -ipady, -padx, -pady, or -side}}
-test pack-12.25 {command options and errors} {
+} -body {
+ pack .pack.a -side right
+ set i [pack info .pack.a]
+ lindex $i [expr [lsearch -exact $i -side]+1]
+} -result right
+
+
+test pack-12.1 {command options and errors} -body {
+ pack
+} -returnCodes error -result {wrong # args: should be "pack option arg ?arg ...?"}
+test pack-12.2 {command options and errors} -body {
+ pack foo
+} -returnCodes error -result {wrong # args: should be "pack option arg ?arg ...?"}
+test pack-12.3 {command options and errors} -body {
+ pack configure x
+} -returnCodes error -result {bad argument "x": must be name of window}
+test pack-12.4 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack configure .pack.b .pack.c
+ pack slaves .pack
+} -result {.pack.b .pack.c}
+test pack-12.5 {command options and errors} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a -padx} msg] $msg
-} {1 {extra option "-padx" (option with no value?)}}
-test pack-12.26 {command options and errors} {
+} -body {
+ pack .foo
+} -returnCodes error -result {bad window path name ".foo"}
+test pack-12.6 {command options and errors} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a ? 22} msg] $msg
-} {1 {bad option "?": must be -after, -anchor, -before, -expand, -fill, -in, -ipadx, -ipady, -padx, -pady, or -side}}
-test pack-12.27 {command options and errors} {
+} -body {
+ pack .pack
+} -returnCodes error -result {can't pack ".pack": it's a top-level window}
+test pack-12.7 {command options and errors} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a -in .} msg] $msg
-} {1 {can't pack .pack.a inside .}}
-test pack-12.28 {command options and errors} {
+} -body {
+ pack .pack.a -after .foo
+} -returnCodes error -result {bad window path name ".foo"}
+test pack-12.8 {command options and errors} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -after .pack.b
+} -returnCodes error -result {window ".pack.b" isn't packed}
+test pack-12.9 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -anchor gorp
+} -returnCodes error -result {bad anchor "gorp": must be n, ne, e, se, s, sw, w, nw, or center}
+test pack-12.10 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -before gorp
+} -returnCodes error -result {bad window path name "gorp"}
+test pack-12.11 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -before .pack.b
+} -returnCodes error -result {window ".pack.b" isn't packed}
+test pack-12.12 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -expand "who cares?"
+} -returnCodes error -result {expected boolean value but got "who cares?"}
+test pack-12.13 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -fill z
+} -returnCodes error -result {bad fill style "z": must be none, x, y, or both}
+test pack-12.14 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -in z
+} -returnCodes error -result {bad window path name "z"}
+set pad [winfo pixels .pack 1c]
+test pack-12.15 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -padx abc
+} -returnCodes error -result {bad pad value "abc": must be positive screen distance}
+test pack-12.16 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -padx {5 abc}
+} -returnCodes error -result {bad 2nd pad value "abc": must be positive screen distance}
+test pack-12.17 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -padx -1
+} -returnCodes error -result {bad pad value "-1": must be positive screen distance}
+test pack-12.18 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -padx {5 -1}
+} -returnCodes error -result {bad 2nd pad value "-1": must be positive screen distance}
+test pack-12.19 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -pady abc
+} -returnCodes error -result {bad pad value "abc": must be positive screen distance}
+test pack-12.20 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -pady {0 abc}
+} -returnCodes error -result {bad 2nd pad value "abc": must be positive screen distance}
+test pack-12.21 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -pady -1
+} -returnCodes error -result {bad pad value "-1": must be positive screen distance}
+test pack-12.22 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -pady {0 -1}
+} -returnCodes error -result {bad 2nd pad value "-1": must be positive screen distance}
+test pack-12.23 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -ipadx abc
+} -returnCodes error -result {bad ipadx value "abc": must be positive screen distance}
+test pack-12.24 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -ipadx -1
+} -returnCodes error -result {bad ipadx value "-1": must be positive screen distance}
+test pack-12.25 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -ipadx {5 5}
+} -returnCodes error -result {bad ipadx value "5 5": must be positive screen distance}
+test pack-12.26 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -ipady abc
+} -returnCodes error -result {bad ipady value "abc": must be positive screen distance}
+test pack-12.27 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -ipady -1
+} -returnCodes error -result {bad ipady value "-1": must be positive screen distance}
+test pack-12.28 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -ipady {5 5}
+} -returnCodes error -result {bad ipady value "5 5": must be positive screen distance}
+test pack-12.29 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -side bac
+} -returnCodes error -result {bad side "bac": must be top, bottom, left, or right}
+test pack-12.30 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -lousy bac
+} -returnCodes error -result {bad option "-lousy": must be -after, -anchor, -before, -expand, -fill, -in, -ipadx, -ipady, -padx, -pady, or -side}
+test pack-12.31 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -padx
+} -returnCodes error -result {extra option "-padx" (option with no value?)}
+test pack-12.32 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a ? 22
+} -returnCodes error -result {bad option "?": must be -after, -anchor, -before, -expand, -fill, -in, -ipadx, -ipady, -padx, -pady, or -side}
+test pack-12.33 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a -in .
+} -returnCodes error -result {can't pack .pack.a inside .}
+test pack-12.34 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
frame .pack.a.a
- list [catch {pack .pack.a.a -in .pack.b} msg] $msg
-} {1 {can't pack .pack.a.a inside .pack.b}}
-test pack-12.29 {command options and errors} {
+ pack .pack.a.a -in .pack.b
+} -returnCodes error -result {can't pack .pack.a.a inside .pack.b}
+test pack-12.35 {command options and errors} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack .pack.a -in .pack.a} msg] $msg
-} {1 {can't pack .pack.a inside itself}}
-test pack-12.30 {command options and errors} {
+} -body {
+ pack .pack.a -in .pack.a
+} -returnCodes error -result {can't pack .pack.a inside itself}
+test pack-12.36 {command options and errors} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a .pack.b .pack.c .pack.d
pack forget .pack.a .pack.d
pack slaves .pack
-} {.pack.b .pack.c}
-test pack-12.31 {command options and errors} {
+} -result {.pack.b .pack.c}
+test pack-12.37 {command options and errors} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
.pack configure -width 300 -height 200
pack propagate .pack 0
pack .pack.a
@@ -831,63 +1303,77 @@ test pack-12.31 {command options and errors} {
pack propagate .pack 1
update
lappend result [winfo reqwidth .pack] [winfo reqheight .pack]
- set result
-} {300 200 20 40}
-test pack-12.32 {command options and errors} {
+ return $result
+} -result {300 200 20 40}
+test pack-12.38 {command options and errors} -body {
set result [pack propagate .pack.d]
pack propagate .pack.d 0
lappend result [pack propagate .pack.d]
pack propagate .pack.d 1
lappend result [pack propagate .pack.d]
- set result
-} {1 0 1}
-test pack-12.33 {command options and errors} {
- pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack propagate .dum} msg] $msg
-} {1 {bad window path name ".dum"}}
-test pack-12.34 {command options and errors} {
- pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack propagate .pack foo} msg] $msg
-} {1 {expected boolean value but got "foo"}}
-test pack-12.35 {command options and errors} {
- pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack propagate .pack foo bar} msg] $msg
-} {1 {wrong # args: should be "pack propagate window ?boolean?"}}
-test pack-12.36 {command options and errors} {
- pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack slaves} msg] $msg
-} {1 {wrong # args: should be "pack option arg ?arg ...?"}}
-test pack-12.37 {command options and errors} {
- pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack slaves a b} msg] $msg
-} {1 {wrong # args: should be "pack slaves window"}}
-test pack-12.38 {command options and errors} {
- pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack slaves .x} msg] $msg
-} {1 {bad window path name ".x"}}
-test pack-12.39 {command options and errors} {
- pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack slaves .pack.a} msg] $msg
-} {0 {}}
-test pack-12.40 {command options and errors} {
- pack forget .pack.a .pack.b .pack.c .pack.d
- list [catch {pack lousy .pack} msg] $msg
-} {1 {bad option "lousy": must be configure, forget, info, propagate, or slaves}}
+ return $result
+} -result {1 0 1}
+test pack-12.39 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack propagate .dum
+} -returnCodes error -result {bad window path name ".dum"}
+test pack-12.40 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack propagate .pack foo
+} -returnCodes error -result {expected boolean value but got "foo"}
+test pack-12.41 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack propagate .pack foo bar
+} -returnCodes error -result {wrong # args: should be "pack propagate window ?boolean?"}
+test pack-12.42 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack slaves
+} -returnCodes error -result {wrong # args: should be "pack option arg ?arg ...?"}
+test pack-12.43 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack slaves a b
+} -returnCodes error -result {wrong # args: should be "pack slaves window"}
+test pack-12.44 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack slaves .x
+} -returnCodes error -result {bad window path name ".x"}
+test pack-12.45 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack slaves .pack.a
+} -returnCodes ok -result {}
+test pack-12.46 {command options and errors} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack lousy .pack
+} -returnCodes error -result {bad option "lousy": must be configure, forget, info, propagate, or slaves}
-pack .pack.right -side right
-pack .pack.bottom -side bottom
-test pack-13.1 {window deletion} {
- pack forget .pack.a .pack.b .pack.c .pack.d
+
+test pack-13.1 {window deletion} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d .pack.right .pack.bottom
+} -body {
+ pack .pack.right -side right
+ pack .pack.bottom -side bottom
pack .pack.a .pack.d .pack.b .pack.c -side top
update
destroy .pack.d
update
set result [list [pack slaves .pack] [winfo geometry .pack.a] \
- [winfo geometry .pack.b] [winfo geometry .pack.c]]
-} {{.pack.right .pack.bottom .pack.a .pack.b .pack.c} 20x40+30+0 50x30+15+40 80x80+0+70}
+ [winfo geometry .pack.b] [winfo geometry .pack.c]]
+} -result {{.pack.right .pack.bottom .pack.a .pack.b .pack.c} 20x40+30+0 50x30+15+40 80x80+0+70}
-test pack-14.1 {respond to changes in expansion} {
- pack forget .pack.a .pack.b .pack.c .pack.d
+
+test pack-14.1 {respond to changes in expansion} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d .pack.right .pack.bottom
+} -body {
+ pack .pack.right -side right
+ pack .pack.bottom -side bottom
wm geom .pack {}
pack .pack.a
update
@@ -898,11 +1384,15 @@ test pack-14.1 {respond to changes in expansion} {
pack .pack.a -expand true -fill both
update
lappend result [winfo geom .pack.a]
-} {20x40+0+0 20x40+90+0 200x150+0+0}
-wm geom .pack {}
+} -cleanup {
+ wm geom .pack {}
+} -result {20x40+0+0 20x40+90+0 200x150+0+0}
-test pack-15.1 {managing geometry with -in option} {
+
+test pack-15.1 {managing geometry with -in option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+ destroy .pack.f
+} -body {
pack .pack.a -side top
frame .pack.f
lower .pack.f
@@ -916,10 +1406,13 @@ test pack-15.1 {managing geometry with -in option} {
pack unpack .pack.a
update
lappend result [winfo geom .pack.b]
-} {50x30+0+40 50x30+0+0}
-catch {destroy .pack.f}
-test pack-15.2 {managing geometry with -in option} {
+} -cleanup {
+ destroy .pack.f
+} -result {50x30+0+40 50x30+0+0}
+test pack-15.2 {managing geometry with -in option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+ destroy .pack.f
+} -body {
frame .pack.f
lower .pack.f
pack .pack.a -in .pack.f -side top
@@ -931,10 +1424,13 @@ test pack-15.2 {managing geometry with -in option} {
place forget .pack.f
update
lappend result [winfo ismapped .pack.a]
-} {0 1 20x40+30+45 0}
-catch {destroy .pack.f}
-test pack-15.3 {managing geometry with -in option} {
+} -cleanup {
+ destroy .pack.f
+} -result {0 1 20x40+30+45 0}
+test pack-15.3 {managing geometry with -in option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+ destroy .pack.f
+} -body {
pack .pack.a -side top
frame .pack.f
lower .pack.f
@@ -948,15 +1444,18 @@ test pack-15.3 {managing geometry with -in option} {
pack unpack .pack.f
update
lappend result [winfo ismapped .pack.b]
-} {1 0}
-catch {destroy .pack.f}
-test pack-15.4 {managing geometry with -in option} {
+} -cleanup {
+ destroy .pack.f
+} -result {1 0}
+test pack-15.4 {managing geometry with -in option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+ destroy .pack.f1 .pack.f2
+} -body {
foreach i {1 2} {
- frame .pack.f$i -width 100 -height 40 -bd 2 -relief raised
- lower .pack.f$i
- pack propagate .pack.f$i 0
- pack .pack.f$i -side top
+ frame .pack.f$i -width 100 -height 40 -bd 2 -relief raised
+ lower .pack.f$i
+ pack propagate .pack.f$i 0
+ pack .pack.f$i -side top
}
pack .pack.b -in .pack.f1 -side right
update
@@ -971,15 +1470,18 @@ test pack-15.4 {managing geometry with -in option} {
pack forget .pack.b
update
lappend result [winfo geometry .pack.b] [winfo ismapped .pack.b]
-} {50x30+48+5 1 50x30+25+48 1 50x30+25+28 1 50x30+25+28 0}
-catch {destroy .pack.f1 .pack.f2}
-test pack-15.5 {managing geometry with -in option} {
+} -cleanup {
+ destroy .pack.f1 .pack.f2
+} -result {50x30+48+5 1 50x30+25+48 1 50x30+25+28 1 50x30+25+28 0}
+test pack-15.5 {managing geometry with -in option} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+ destroy .pack.f1 .pack.f2
+} -body {
foreach i {1 2} {
- frame .pack.f$i -width 100 -height 20 -bd 2 -relief raised
- lower .pack.f$i
- pack propagate .pack.f$i 0
- pack .pack.f$i -side top
+ frame .pack.f$i -width 100 -height 20 -bd 2 -relief raised
+ lower .pack.f$i
+ pack propagate .pack.f$i 0
+ pack .pack.f$i -side top
}
pack .pack.b -in .pack.f2 -side top
update
@@ -988,30 +1490,50 @@ test pack-15.5 {managing geometry with -in option} {
pack .pack.a -before .pack.b -side top
update
lappend result [winfo geometry .pack.b] [winfo ismapped .pack.b]
-} {50x16+25+22 1 50x16+25+22 0}
-catch {destroy .pack.f1 .pack.f2}
+} -cleanup {
+ destroy .pack.f1 .pack.f2
+} -result {50x16+25+22 1 50x16+25+22 0}
+
-test pack-16.1 {geometry manager name} {
+test pack-16.1 {geometry manager name} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
set result {}
+} -body {
lappend result [winfo manager .pack.a]
pack .pack.a
lappend result [winfo manager .pack.a]
pack forget .pack.a
lappend result [winfo manager .pack.a]
-} {{} pack {}}
+} -result {{} pack {}}
+
-test pack-17.1 {PackLostSlaveProc procedure} {
+test pack-17.1 {PackLostSlaveProc procedure} -setup {
pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
pack .pack.a
update
place .pack.a -x 40 -y 10
update
- list [winfo manager .pack.a] [winfo geometry .pack.a] \
- [catch {pack info .pack.a} msg] $msg
-} {place 20x40+40+10 1 {window ".pack.a" isn't packed}}
+ list [winfo manager .pack.a] [winfo geometry .pack.a]
+} -result {place 20x40+40+10}
+test pack-17.2 {PackLostSlaveProc procedure} -setup {
+ pack forget .pack.a .pack.b .pack.c .pack.d
+} -body {
+ pack .pack.a
+ update
+ place .pack.a -x 40 -y 10
+ update
+ winfo manager .pack.a
+ winfo geometry .pack.a
+ pack info .pack.a
+} -returnCodes error -result {window ".pack.a" isn't packed}
+
-test pack-18.1 {unmap slaves when master unmapped} {tempNotPc} {
+test pack-18.1 {unmap slaves when master unmapped} -constraints {
+ tempNotPc
+} -setup {
+ eval destroy [winfo child .pack]
+} -body {
# adjust the position of .pack before test to avoid a screen switch
# that occurs with window managers that have desktops four times as big
@@ -1034,19 +1556,20 @@ test pack-18.1 {unmap slaves when master unmapped} {tempNotPc} {
.pack.a configure -width 200 -height 75
update
lappend result [winfo width .pack.a ] [winfo height .pack.a] \
- [winfo ismapped .pack.a]
+ [winfo ismapped .pack.a]
wm deiconify .pack
update
lappend result [winfo ismapped .pack.a]
-} {1 0 200 75 0 1}
-test pack-18.2 {unmap slaves when master unmapped} {
+} -result {1 0 200 75 0 1}
+test pack-18.2 {unmap slaves when master unmapped} -setup {
+ eval destroy [winfo child .pack]
+} -body {
# adjust the position of .pack before test to avoid a screen switch
# that occurs with window managers that have desktops four times as big
# as the screen (screen switch causes scale and other tests to fail).
wm geometry .pack +100+100
- eval destroy [winfo child .pack]
frame .pack.a -relief raised -bd 2
frame .pack.b -width 70 -height 30 -relief sunken -bd 2
pack .pack.a
@@ -1059,15 +1582,17 @@ test pack-18.2 {unmap slaves when master unmapped} {
.pack.b configure -width 100 -height 30
update
lappend result [winfo width .pack.b ] [winfo height .pack.b] \
- [winfo ismapped .pack.b]
+ [winfo ismapped .pack.b]
wm deiconify .pack
update
lappend result [winfo ismapped .pack.b]
-} {1 0 100 30 0 1}
+} -result {1 0 100 30 0 1}
+
-test pack-19.1 {test respect for internalborder} {
+test pack-19.1 {test respect for internalborder} -setup {
catch {eval pack forget [pack slaves .pack]}
destroy .pack.l .pack.lf
+} -body {
wm geometry .pack 200x200
frame .pack.l -width 15 -height 10
labelframe .pack.lf -labelwidget .pack.l
@@ -1079,12 +1604,13 @@ test pack-19.1 {test respect for internalborder} {
.pack.lf configure -labelanchor e -padx 3 -pady 5
update
lappend res [winfo geometry .pack.lf.f]
+} -cleanup {
destroy .pack.l .pack.lf
- set res
-} {196x188+2+10 177x186+5+7}
-test pack-19.2 {test support for minreqsize} {
+} -result {196x188+2+10 177x186+5+7}
+test pack-19.2 {test support for minreqsize} -setup {
catch {eval pack forget [pack slaves .pack]}
destroy .pack.l .pack.lf
+} -body {
wm geometry .pack {}
frame .pack.l -width 150 -height 100
labelframe .pack.lf -labelwidget .pack.l
@@ -1096,15 +1622,14 @@ test pack-19.2 {test support for minreqsize} {
.pack.lf configure -labelanchor ws
update
lappend res [winfo geometry .pack.lf]
+} -cleanup {
destroy .pack.l .pack.lf
- set res
-} {162x127+0+0 172x112+0+0}
+} -result {162x127+0+0 172x112+0+0}
-destroy .pack
-foreach i {pack1 pack2 pack3 pack4} {
- rename $i {}
-}
# cleanup
cleanupTests
return
+
+
+
diff --git a/tests/packgrid.test b/tests/packgrid.test
new file mode 100644
index 0000000..355b49d
--- /dev/null
+++ b/tests/packgrid.test
@@ -0,0 +1,250 @@
+# This file is a Tcl script to test out interaction between Tk's "pack" and
+# "grid" commands.
+# It is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 2008 Peter Spjuth
+# All rights reserved.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::*
+
+test packgrid-1.1 {pack and grid in same master} -setup {
+ grid propagate . true
+ pack propagate . true
+ label .p -text PACK
+ label .g -text GRID
+} -body {
+ # Basic conflict
+ grid .g
+ pack .p
+} -returnCodes error -cleanup {
+ destroy .p
+ destroy .g
+} -result {cannot use geometry manager pack inside . which already has slaves managed by grid}
+
+test packgrid-1.2 {pack and grid in same master} -setup {
+ grid propagate . true
+ pack propagate . true
+ label .p -text PACK
+ label .g -text GRID
+} -body {
+ # Basic conflict
+ pack .p
+ grid .g
+} -returnCodes error -cleanup {
+ destroy .p
+ destroy .g
+} -result {cannot use geometry manager grid inside . which already has slaves managed by pack}
+
+test packgrid-1.3 {pack and grid in same master} -setup {
+ grid propagate . false
+ pack propagate . true
+ label .p -text PACK
+ label .g -text GRID
+} -body {
+ # Ok if one is non-propagating
+ grid .g
+ pack .p
+} -cleanup {
+ destroy .p
+ destroy .g
+} -result {}
+
+test packgrid-1.4 {pack and grid in same master} -setup {
+ grid propagate . false
+ pack propagate . true
+ label .p -text PACK
+ label .g -text GRID
+} -body {
+ # Ok if one is non-propagating
+ pack .p
+ grid .g
+} -cleanup {
+ destroy .p
+ destroy .g
+} -result {}
+
+test packgrid-1.5 {pack and grid in same master} -setup {
+ grid propagate . true
+ pack propagate . false
+ label .p -text PACK
+ label .g -text GRID
+} -body {
+ # Ok if one is non-propagating
+ grid .g
+ pack .p
+} -cleanup {
+ destroy .p
+ destroy .g
+} -result {}
+
+test packgrid-1.6 {pack and grid in same master} -setup {
+ grid propagate . true
+ pack propagate . false
+ label .p -text PACK
+ label .g -text GRID
+} -body {
+ # Ok if one is non-propagating
+ pack .p
+ grid .g
+} -cleanup {
+ destroy .p
+ destroy .g
+} -result {}
+
+test packgrid-1.7 {pack and grid in same master} -setup {
+ grid propagate . true
+ pack propagate . true
+ label .p -text PACK
+ label .g -text GRID
+} -body {
+ # Basic conflict should stop widget from being handled
+ grid .g
+ catch { pack .p }
+ pack slaves .
+} -cleanup {
+ destroy .p
+ destroy .g
+} -result {}
+
+test packgrid-1.8 {pack and grid in same master} -setup {
+ grid propagate . true
+ pack propagate . true
+ label .p -text PACK
+ label .g -text GRID
+} -body {
+ # Basic conflict should stop widget from being handled
+ pack .p
+ catch { grid .g }
+ grid slaves .
+} -cleanup {
+ destroy .p
+ destroy .g
+} -result {}
+
+test packgrid-2.1 {pack and grid in same master, change propagation} -setup {
+ grid propagate . false
+ pack propagate . true
+ label .p -text PACK
+ label .g -text GRID
+ pack .p
+ grid .g
+ update
+} -body {
+ grid propagate . true
+} -returnCodes error -cleanup {
+ destroy .p
+ destroy .g
+} -result {cannot use geometry manager grid inside . which already has slaves managed by pack}
+
+test packgrid-2.2 {pack and grid in same master, change propagation} -setup {
+ grid propagate . true
+ pack propagate . false
+ label .p -text PACK
+ label .g -text GRID
+ pack .p
+ grid .g
+ update
+} -body {
+ pack propagate . true
+} -returnCodes error -cleanup {
+ destroy .p
+ update
+ destroy .g
+} -result {cannot use geometry manager pack inside . which already has slaves managed by grid}
+
+test packgrid-2.3 {pack and grid in same master, change propagation} -setup {
+ grid propagate . false
+ pack propagate . false
+ label .p -text PACK
+ label .g -text GRID
+ pack .p
+ grid .g
+ update
+} -body {
+ grid propagate . true
+ update
+ pack propagate . true
+} -returnCodes error -cleanup {
+ destroy .p
+ destroy .g
+} -result {cannot use geometry manager pack inside . which already has slaves managed by grid}
+
+test packgrid-2.4 {pack and grid in same master, change propagation} -setup {
+ grid propagate . false
+ pack propagate . false
+ label .p -text PACK
+ label .g -text GRID
+ pack .p
+ grid .g
+ update
+} -body {
+ pack propagate . true
+ grid propagate . true
+} -returnCodes error -cleanup {
+ destroy .p
+ destroy .g
+} -result {cannot use geometry manager grid inside . which already has slaves managed by pack}
+
+test packgrid-3.1 {stealing slave} -setup {
+ grid propagate . true
+ pack propagate . true
+ label .p -text PACK
+ label .g -text GRID
+} -body {
+ # Ok to steal if the other one is emptied
+ grid .g
+ pack .g
+} -cleanup {
+ destroy .p
+ destroy .g
+} -result {}
+
+test packgrid-3.2 {stealing slave} -setup {
+ grid propagate . true
+ pack propagate . true
+ label .p -text PACK
+ label .g -text GRID
+} -body {
+ # Ok to steal if the other one is emptied
+ pack .g
+ grid .g
+} -cleanup {
+ destroy .p
+ destroy .g
+} -result {}
+
+test packgrid-3.3 {stealing slave} -setup {
+ grid propagate . true
+ pack propagate . true
+ label .p -text PACK
+ label .g -text GRID
+} -body {
+ # Not ok to steal if the other one is not emptied
+ grid .g
+ grid .p
+ pack .g
+} -returnCodes error -cleanup {
+ destroy .p
+ destroy .g
+} -result {cannot use geometry manager pack inside . which already has slaves managed by grid}
+
+test packgrid-3.4 {stealing slave} -setup {
+ grid propagate . true
+ pack propagate . true
+ label .p -text PACK
+ label .g -text GRID
+} -body {
+ # Not ok to steal if the other one is not emptied
+ pack .g
+ pack .p
+ grid .g
+} -returnCodes error -cleanup {
+ destroy .p
+ destroy .g
+} -result {cannot use geometry manager grid inside . which already has slaves managed by pack}
+
+cleanupTests
+return
diff --git a/tests/panedwindow.test b/tests/panedwindow.test
index c7d84b8..f2e01e8 100644
--- a/tests/panedwindow.test
+++ b/tests/panedwindow.test
@@ -6,123 +6,312 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
+namespace import -force tcltest::test
-set i 1
+deleteWindows
+# Panedwindow for tests 1.*
panedwindow .p
-foreach {testName testData} {
- panedwindow-1.1 {-background
- "#ff0000" "#ff0000" non-existent {unknown color name "non-existent"}}
- panedwindow-1.2 {-bd
- 4 4 badValue {bad screen distance "badValue"}}
- panedwindow-1.3 {-bg
- "#ff0000" "#ff0000" non-existent {unknown color name "non-existent"}}
- panedwindow-1.4 {-borderwidth
- 1.3 1 badValue {bad screen distance "badValue"}}
- panedwindow-1.5 {-cursor
- arrow arrow badValue {bad cursor spec "badValue"}}
- panedwindow-1.6 {-handlesize
- 20 20 badValue {bad screen distance "badValue"}}
- panedwindow-1.7 {-height
- 20 20 badValue {bad screen distance "badValue"}}
- panedwindow-1.8 {-opaqueresize
- true 1 foo {expected boolean value but got "foo"}}
- panedwindow-1.9 {-orient
- horizontal horizontal
- badValue {bad orient "badValue": must be horizontal or vertical}}
- panedwindow-1.10 {-relief
- groove groove
- 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}}
- panedwindow-1.11 {-sashcursor
- arrow arrow badValue {bad cursor spec "badValue"}}
- panedwindow-1.12 {-sashpad
- 1.3 1 badValue {bad screen distance "badValue"}}
- panedwindow-1.13 {-sashrelief
- groove groove
- 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}}
- panedwindow-1.14 {-sashwidth
- 10 10 badValue {bad screen distance "badValue"}}
- panedwindow-1.15 {-showhandle
- true 1 foo {expected boolean value but got "foo"}}
- panedwindow-1.16 {-width
- 402 402 badValue {bad screen distance "badValue"}}
-} {
- lassign $testData optionName goodIn goodOut badIn badOut
- test ${testName}(good) "configuration options: $optionName" {
- .p configure $optionName $goodIn
- list [lindex [.p configure $optionName] 4] [.p cget $optionName]
- } [list $goodOut $goodOut]
- test ${testName}(bad) "configuration options: $optionName" -body {
- .p configure $optionName $badIn
- } -returnCodes error -result $badOut
- # Reset to default
- .p configure $optionName [lindex [.p configure $optionName] 3]
-}
+# Buttons for tests 1.33 - 1.52
.p add [button .b]
.p add [button .c]
-foreach {testName testData} {
- panedwindow-1a.1 {-after .c .c badValue {bad window path name "badValue"}}
- panedwindow-1a.2 {-before .c .c badValue {bad window path name "badValue"}}
- panedwindow-1a.3 {-height 10 10 badValue {bad screen distance "badValue"}}
- panedwindow-1a.4 {-hide false 0 foo {expected boolean value but got "foo"}}
- panedwindow-1a.5 {-minsize 10 10 badValue {bad screen distance "badValue"}}
- panedwindow-1a.6 {-padx 1.3 1 badValue {bad screen distance "badValue"}}
- panedwindow-1a.7 {-pady 1.3 1 badValue {bad screen distance "badValue"}}
- panedwindow-1a.8 {-sticky nsew nesw abcd {bad stickyness value "abcd": must be a string containing zero or more of n, e, s, and w}}
- panedwindow-1a.9 {-stretch alw always foo {bad stretch "foo": must be always, first, last, middle, or never}}
- panedwindow-1a.10 {-width 10 10 badValue {bad screen distance "badValue"}}
-} {
- lassign $testData optionName goodIn goodOut badIn badOut
- test ${testName}(good) "configuration options: $optionName" {
- .p paneconfigure .b $optionName $goodIn
- list [lindex [.p paneconfigure .b $optionName] 4] \
- [.p panecget .b $optionName]
- } [list $goodOut $goodOut]
- test ${testName}(bad) "configuration options: $optionName" -body {
- .p paneconfigure .b $optionName $badIn
- } -returnCodes error -result $badOut
- # Reset to default
- .p paneconfig .b $optionName [lindex [.p paneconfig .b $optionName] 3]
-}
-destroy .p .b .c
-
-test panedwindow-2.1 {panedwindow widget command} {
- panedwindow .p
- set result [list [catch {.p foo} msg] $msg]
- destroy .p
- set result
-} {1 {bad command "foo": must be add, cget, configure, forget, identify, panecget, paneconfigure, panes, proxy, or sash}}
+test panedwindow-1.1 {configuration options: -background (good)} -body {
+ .p configure -background #ff0000
+ list [lindex [.p configure -background] 4] [.p cget -background]
+} -cleanup {
+ .p configure -background [lindex [.p configure -background] 3]
+} -result {{#ff0000} #ff0000}
+test panedwindow-1.2 {configuration options: -background (bad)} -body {
+ .p configure -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test panedwindow-1.3 {configuration options: -bd (good)} -body {
+ .p configure -bd 4
+ list [lindex [.p configure -bd] 4] [.p cget -bd]
+} -cleanup {
+ .p configure -bd [lindex [.p configure -bd] 3]
+} -result {4 4}
+test panedwindow-1.4 {configuration options: -bd (bad)} -body {
+ .p configure -bd badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test panedwindow-1.5 {configuration options: -bg (good)} -body {
+ .p configure -bg #ff0000
+ list [lindex [.p configure -bg] 4] [.p cget -bg]
+} -cleanup {
+ .p configure -bg [lindex [.p configure -bg] 3]
+} -result {{#ff0000} #ff0000}
+test panedwindow-1.6 {configuration options: -bg (bad)} -body {
+ .p configure -bg non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test panedwindow-1.7 {configuration options: -borderwidth (good)} -body {
+ .p configure -borderwidth 1.3
+ list [lindex [.p configure -borderwidth] 4] [.p cget -borderwidth]
+} -cleanup {
+ .p configure -borderwidth [lindex [.p configure -borderwidth] 3]
+} -result {1 1}
+test panedwindow-1.8 {configuration options: -borderwidth (bad)} -body {
+ .p configure -borderwidth badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test panedwindow-1.9 {configuration options: -cursor (good)} -body {
+ .p configure -cursor arrow
+ list [lindex [.p configure -cursor] 4] [.p cget -cursor]
+} -cleanup {
+ .p configure -cursor [lindex [.p configure -cursor] 3]
+} -result {arrow arrow}
+test panedwindow-1.10 {configuration options: -cursor (bad)} -body {
+ .p configure -cursor badValue
+} -returnCodes error -result {bad cursor spec "badValue"}
+test panedwindow-1.11 {configuration options: -handlesize (good)} -body {
+ .p configure -handlesize 20
+ list [lindex [.p configure -handlesize] 4] [.p cget -handlesize]
+} -cleanup {
+ .p configure -handlesize [lindex [.p configure -handlesize] 3]
+} -result {20 20}
+test panedwindow-1.12 {configuration options: -handlesize (bad)} -body {
+ .p configure -handlesize badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test panedwindow-1.13 {configuration options: -height (good)} -body {
+ .p configure -height 20
+ list [lindex [.p configure -height] 4] [.p cget -height]
+} -cleanup {
+ .p configure -height [lindex [.p configure -height] 3]
+} -result {20 20}
+test panedwindow-1.14 {configuration options: -height (bad)} -body {
+ .p configure -height badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test panedwindow-1.15 {configuration options: -opaqueresize (good)} -body {
+ .p configure -opaqueresize true
+ list [lindex [.p configure -opaqueresize] 4] [.p cget -opaqueresize]
+} -cleanup {
+ .p configure -opaqueresize [lindex [.p configure -opaqueresize] 3]
+} -result {1 1}
+test panedwindow-1.16 {configuration options: -opaqueresize (bad)} -body {
+ .p configure -opaqueresize foo
+} -returnCodes error -result {expected boolean value but got "foo"}
+test panedwindow-1.17 {configuration options: -orient (good)} -body {
+ .p configure -orient horizontal
+ list [lindex [.p configure -orient] 4] [.p cget -orient]
+} -cleanup {
+ .p configure -orient [lindex [.p configure -orient] 3]
+} -result {horizontal horizontal}
+test panedwindow-1.18 {configuration options: -orient (bad)} -body {
+ .p configure -orient badValue
+} -returnCodes error -result {bad orient "badValue": must be horizontal or vertical}
+test panedwindow-1.19 {configuration options: -relief (good)} -body {
+ .p configure -relief groove
+ list [lindex [.p configure -relief] 4] [.p cget -relief]
+} -cleanup {
+ .p configure -relief [lindex [.p configure -relief] 3]
+} -result {groove groove}
+test panedwindow-1.20 {configuration options: -relief (bad)} -body {
+ .p configure -relief 1.5
+} -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+test panedwindow-1.21 {configuration options: -sashcursor (good)} -body {
+ .p configure -sashcursor arrow
+ list [lindex [.p configure -sashcursor] 4] [.p cget -sashcursor]
+} -cleanup {
+ .p configure -sashcursor [lindex [.p configure -sashcursor] 3]
+} -result {arrow arrow}
+test panedwindow-1.22 {configuration options: -sashcursor (bad)} -body {
+ .p configure -sashcursor badValue
+} -returnCodes error -result {bad cursor spec "badValue"}
+test panedwindow-1.23 {configuration options: -sashpad (good)} -body {
+ .p configure -sashpad 1.3
+ list [lindex [.p configure -sashpad] 4] [.p cget -sashpad]
+} -cleanup {
+ .p configure -sashpad [lindex [.p configure -sashpad] 3]
+} -result {1 1}
+test panedwindow-1.24 {configuration options: -sashpad (bad)} -body {
+ .p configure -sashpad badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test panedwindow-1.25 {configuration options: -sashrelief (good)} -body {
+ .p configure -sashrelief groove
+ list [lindex [.p configure -sashrelief] 4] [.p cget -sashrelief]
+} -cleanup {
+ .p configure -sashrelief [lindex [.p configure -sashrelief] 3]
+} -result {groove groove}
+test panedwindow-1.26 {configuration options: -sashrelief (bad)} -body {
+ .p configure -sashrelief 1.5
+} -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+test panedwindow-1.27 {configuration options: -sashwidth (good)} -body {
+ .p configure -sashwidth 10
+ list [lindex [.p configure -sashwidth] 4] [.p cget -sashwidth]
+} -cleanup {
+ .p configure -sashwidth [lindex [.p configure -sashwidth] 3]
+} -result {10 10}
+test panedwindow-1.28 {configuration options: -sashwidth (bad)} -body {
+ .p configure -sashwidth badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test panedwindow-1.29 {configuration options: -showhandle (good)} -body {
+ .p configure -showhandle true
+ list [lindex [.p configure -showhandle] 4] [.p cget -showhandle]
+} -cleanup {
+ .p configure -showhandle [lindex [.p configure -showhandle] 3]
+} -result {1 1}
+test panedwindow-1.30 {configuration options: -showhandle (bad)} -body {
+ .p configure -showhandle foo
+} -returnCodes error -result {expected boolean value but got "foo"}
+test panedwindow-1.31 {configuration options: -width (good)} -body {
+ .p configure -width 402
+ list [lindex [.p configure -width] 4] [.p cget -width]
+} -cleanup {
+ .p configure -width [lindex [.p configure -width] 3]
+} -result {402 402}
+test panedwindow-1.32 {configuration options: -width (bad)} -body {
+ .p configure -width badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+
+test panedwindow-1.33 {configuration options: -after (good)} -body {
+ .p paneconfigure .b -after .c
+ list [lindex [.p paneconfigure .b -after] 4] \
+ [.p panecget .b -after]
+} -cleanup {
+ .p paneconfig .b -after [lindex [.p paneconfig .b -after] 3]
+} -result {.c .c}
+test panedwindow-1.34 {configuration options: -after (bad)} -body {
+ .p paneconfigure .b -after badValue
+} -returnCodes error -result {bad window path name "badValue"}
+test panedwindow-1.35 {configuration options: -before (good)} -body {
+ .p paneconfigure .b -before .c
+ list [lindex [.p paneconfigure .b -before] 4] \
+ [.p panecget .b -before]
+} -cleanup {
+ .p paneconfig .b -before [lindex [.p paneconfig .b -before] 3]
+} -result {.c .c}
+test panedwindow-1.36 {configuration options: -before (bad)} -body {
+ .p paneconfigure .b -before badValue
+} -returnCodes error -result {bad window path name "badValue"}
+test panedwindow-1.37 {configuration options: -height (good)} -body {
+ .p paneconfigure .b -height 10
+ list [lindex [.p paneconfigure .b -height] 4] \
+ [.p panecget .b -height]
+} -cleanup {
+ .p paneconfig .b -height [lindex [.p paneconfig .b -height] 3]
+} -result {10 10}
+test panedwindow-1.38 {configuration options: -height (bad)} -body {
+ .p paneconfigure .b -height badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test panedwindow-1.39 {configuration options: -hide (good)} -body {
+ .p paneconfigure .b -hide false
+ list [lindex [.p paneconfigure .b -hide] 4] \
+ [.p panecget .b -hide]
+} -cleanup {
+ .p paneconfig .b -hide [lindex [.p paneconfig .b -hide] 3]
+} -result {0 0}
+test panedwindow-1.40 {configuration options: -hide (bad)} -body {
+ .p paneconfigure .b -hide foo
+} -returnCodes error -result {expected boolean value but got "foo"}
+test panedwindow-1.41 {configuration options: -minsize (good)} -body {
+ .p paneconfigure .b -minsize 10
+ list [lindex [.p paneconfigure .b -minsize] 4] \
+ [.p panecget .b -minsize]
+} -cleanup {
+ .p paneconfig .b -minsize [lindex [.p paneconfig .b -minsize] 3]
+} -result {10 10}
+test panedwindow-1.42 {configuration options: -minsize (bad)} -body {
+ .p paneconfigure .b -minsize badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test panedwindow-1.43 {configuration options: -padx (good)} -body {
+ .p paneconfigure .b -padx 1.3
+ list [lindex [.p paneconfigure .b -padx] 4] \
+ [.p panecget .b -padx]
+} -cleanup {
+ .p paneconfig .b -padx [lindex [.p paneconfig .b -padx] 3]
+} -result {1 1}
+test panedwindow-1.44 {configuration options: -padx (bad)} -body {
+ .p paneconfigure .b -padx badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test panedwindow-1.45 {configuration options: -pady (good)} -body {
+ .p paneconfigure .b -pady 1.3
+ list [lindex [.p paneconfigure .b -pady] 4] \
+ [.p panecget .b -pady]
+} -cleanup {
+ .p paneconfig .b -pady [lindex [.p paneconfig .b -pady] 3]
+} -result {1 1}
+test panedwindow-1.46 {configuration options: -pady (bad)} -body {
+ .p paneconfigure .b -pady badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test panedwindow-1.47 {configuration options: -sticky (good)} -body {
+ .p paneconfigure .b -sticky nsew
+ list [lindex [.p paneconfigure .b -sticky] 4] \
+ [.p panecget .b -sticky]
+} -cleanup {
+ .p paneconfig .b -sticky [lindex [.p paneconfig .b -sticky] 3]
+} -result {nesw nesw}
+test panedwindow-1.48 {configuration options: -sticky (bad)} -body {
+ .p paneconfigure .b -sticky abcd
+} -returnCodes error -result {bad stickyness value "abcd": must be a string containing zero or more of n, e, s, and w}
+test panedwindow-1.49 {configuration options: -stretch (good)} -body {
+ .p paneconfigure .b -stretch alw
+ list [lindex [.p paneconfigure .b -stretch] 4] \
+ [.p panecget .b -stretch]
+} -cleanup {
+ .p paneconfig .b -stretch [lindex [.p paneconfig .b -stretch] 3]
+} -result {always always}
+test panedwindow-1.50 {configuration options: -stretch (bad)} -body {
+ .p paneconfigure .b -stretch foo
+} -returnCodes error -result {bad stretch "foo": must be always, first, last, middle, or never}
+test panedwindow-1.51 {configuration options: -width (good)} -body {
+ .p paneconfigure .b -width 10
+ list [lindex [.p paneconfigure .b -width] 4] \
+ [.p panecget .b -width]
+} -cleanup {
+ .p paneconfig .b -width [lindex [.p paneconfig .b -width] 3]
+} -result {10 10}
+test panedwindow-1.52 {configuration options: -width (bad)} -body {
+ .p paneconfigure .b -width badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+deleteWindows
+
+
+test panedwindow-2.1 {panedwindow widget command} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p
+ .p foo
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {bad command "foo": must be add, cget, configure, forget, identify, panecget, paneconfigure, panes, proxy, or sash}
-test panedwindow-3.1 {panedwindow panes subcommand} {
+
+test panedwindow-3.1 {panedwindow panes subcommand} -setup {
+ deleteWindows
+} -body {
panedwindow .p
.p add [button .b]
.p add [button .c]
set result [list [.p panes]]
.p forget .b
lappend result [.p panes]
- destroy .p .b .c
- set result
-} [list [list .b .c] [list .c]]
+} -cleanup {
+ deleteWindows
+} -result [list [list .b .c] [list .c]]
+
-test panedwindow-4.1 {forget subcommand} {
+test panedwindow-4.1 {forget subcommand} -setup {
+ deleteWindows
+} -body {
panedwindow .p
- set result [list [catch {.p forget} msg] $msg]
- destroy .p
- set result
-} [list 1 "wrong # args: should be \".p forget widget ?widget ...?\""]
-test panedwindow-4.2 {forget subcommand, forget one from start} {
+ .p forget
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {wrong # args: should be ".p forget widget ?widget ...?"}
+test panedwindow-4.2 {forget subcommand, forget one from start} -setup {
+ deleteWindows
+} -body {
panedwindow .p
.p add [button .b]
.p add [button .c]
set result [list [.p panes]]
.p forget .b
lappend result [.p panes]
- destroy .p .b .c
- set result
-} [list {.b .c} .c]
-test panedwindow-4.3 {forget subcommand, forget one from end} {
+} -cleanup {
+ deleteWindows
+} -result [list {.b .c} .c]
+test panedwindow-4.3 {forget subcommand, forget one from end} -setup {
+ deleteWindows
+} -body {
panedwindow .p
.p add [button .b]
.p add [button .c]
@@ -131,10 +320,12 @@ test panedwindow-4.3 {forget subcommand, forget one from end} {
.p forget .d
update
lappend result [.p panes]
- destroy .p .b .c .d
- set result
-} [list {.b .c .d} {.b .c}]
-test panedwindow-4.4 {forget subcommand, forget multiple} {
+} -cleanup {
+ deleteWindows
+} -result [list {.b .c .d} {.b .c}]
+test panedwindow-4.4 {forget subcommand, forget multiple} -setup {
+ deleteWindows
+} -body {
panedwindow .p
.p add [button .b]
.p add [button .c]
@@ -143,317 +334,401 @@ test panedwindow-4.4 {forget subcommand, forget multiple} {
.p forget .b .c
update
lappend result [.p panes]
- destroy .p .b .c .d
- set result
-} [list {.b .c .d} .d]
-test panedwindow-4.5 {forget subcommand, panes are unmapped} {
+} -cleanup {
+ deleteWindows
+} -result [list {.b .c .d} .d]
+test panedwindow-4.5 {forget subcommand, panes are unmapped} -setup {
+ deleteWindows
+} -body {
panedwindow .p
.p add [button .b]
.p add [button .c]
pack .p
update
-
set result [list [winfo ismapped .b] [winfo ismapped .c]]
.p forget .b
update
-
lappend result [winfo ismapped .b] [winfo ismapped .c]
- destroy .p .b .c
-
- set result
-} [list 1 1 0 1]
-test panedwindow-4.6 {forget subcommand, changes reqsize of panedwindow} {
+} -cleanup {
+ deleteWindows
+} -result [list 1 1 0 1]
+test panedwindow-4.6 {forget subcommand, changes reqsize of panedwindow} -setup {
+ deleteWindows
+} -body {
panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -showhandle false
.p add [frame .f -width 20 -height 20] [frame .g -width 20 -height 20]
set result [list [winfo reqwidth .p]]
.p forget .f
lappend result [winfo reqwidth .p]
- destroy .p .f .g
- set result
-} [list 44 20]
+} -cleanup {
+ deleteWindows
+} -result [list 44 20]
+
-test panedwindow-5.1 {sash subcommand} {
+test panedwindow-5.1 {sash subcommand} -setup {
+ deleteWindows
+} -body {
panedwindow .p
- set result [list [catch {.p sash} msg] $msg]
- destroy .p
- set result
-} [list 1 "wrong # args: should be \".p sash option ?arg ...?\""]
-test panedwindow-5.2 {sash subcommand} {
+ .p sash
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {wrong # args: should be ".p sash option ?arg ...?"}
+test panedwindow-5.2 {sash subcommand} -setup {
+ deleteWindows
+} -body {
panedwindow .p
- set result [list [catch {.p sash foo} msg] $msg]
- destroy .p
- set result
-} [list 1 "bad option \"foo\": must be coord, dragto, mark, or place"]
+ .p sash foo
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {bad option "foo": must be coord, dragto, mark, or place}
-test panedwindow-6.1 {sash coord subcommand, errors} {
+
+test panedwindow-6.1 {sash coord subcommand, errors} -setup {
+ deleteWindows
+} -body {
panedwindow .p
- set result [list [catch {.p sash coord} msg] $msg]
- destroy .p
- set result
-} [list 1 "wrong # args: should be \".p sash coord index\""]
-test panedwindow-6.2 {sash coord subcommand, errors} {
+ .p sash coord
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {wrong # args: should be ".p sash coord index"}
+test panedwindow-6.2 {sash coord subcommand, errors} -setup {
+ deleteWindows
+} -body {
panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4
- set result [list [catch {.p sash coord 0} msg] $msg]
- destroy .p
- set result
-} [list 1 "invalid sash index"]
-test panedwindow-6.3 {sash coord subcommand, errors} {
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {invalid sash index}
+test panedwindow-6.3 {sash coord subcommand, errors} -setup {
+ deleteWindows
+} -body {
panedwindow .p
- set result [list [catch {.p sash coord foo} msg] $msg]
- destroy .p
- set result
-} [list 1 "expected integer but got \"foo\""]
-test panedwindow-6.4 {sash coord subcommand sashes correctly placed} {
+ .p sash coord foo
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "foo"}
+test panedwindow-6.4 {sash coord subcommand sashes correctly placed} -setup {
+ deleteWindows
+} -body {
panedwindow .p -borderwidth 0 -sashpad 2 -sashwidth 4 -showhandle false
.p add [frame .p.f -width 20 -height 20] \
[frame .p.f2 -width 20 -height 20] \
[frame .p.f3 -width 20 -height 20]
- set result [.p sash coord 0]
- destroy .p .p.f .p.f2 .p.f3
- set result
-} [list 22 0]
-test panedwindow-6.5 {sash coord subcommand sashes correctly placed} {
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 22 0]
+test panedwindow-6.5 {sash coord subcommand sashes correctly placed} -setup {
+ deleteWindows
+} -body {
panedwindow .p -borderwidth 0 -sashpad 2 -sashwidth 4 -showhandle false
.p add [frame .p.f -width 20 -height 20] \
[frame .p.f2 -width 20 -height 20] \
[frame .p.f3 -width 20 -height 20]
- set result [.p sash coord 1]
- destroy .p .p.f .p.f2 .p.f3
- set result
-} [list 50 0]
-test panedwindow-6.6 {sash coord subcommand, sashes correctly placed} {
+ .p sash coord 1
+} -cleanup {
+ deleteWindows
+} -result [list 50 0]
+test panedwindow-6.6 {sash coord subcommand, sashes correctly placed} -setup {
+ deleteWindows
+} -body {
panedwindow .p -borderwidth 0 -sashpad 2 -sashwidth 4 -orient vertical \
-showhandle false
.p add [frame .p.f -width 20 -height 20] \
[frame .p.f2 -width 20 -height 20] \
[frame .p.f3 -width 20 -height 20]
- set result [.p sash coord 0]
- destroy .p .p.f .p.f2 .p.f3
- set result
-} [list 0 22]
-test panedwindow-6.7 {sash coord subcommand, sashes correctly placed} {
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 22]
+test panedwindow-6.7 {sash coord subcommand, sashes correctly placed} -setup {
+ deleteWindows
+} -body {
panedwindow .p -borderwidth 0 -sashpad 2 -sashwidth 4 -orient vertical \
-showhandle false
.p add [frame .p.f -width 20 -height 20] \
[frame .p.f2 -width 20 -height 20] \
[frame .p.f3 -width 20 -height 20]
- set result [.p sash coord 1]
- destroy .p .p.f .p.f2 .p.f3
- set result
-} [list 0 50]
-test panedwindow-6.8 {sash coord subcommand, errors} {
+ .p sash coord 1
+} -cleanup {
+ deleteWindows
+} -result [list 0 50]
+test panedwindow-6.8 {sash coord subcommand, errors} -setup {
+ deleteWindows
+} -body {
panedwindow .p
- set result [list \
- [catch {.p sash coord -1} msg] $msg \
- [catch {.p sash coord 0} msg] $msg \
- [catch {.p sash coord 1} msg] $msg \
- ]
- destroy .p
- set result
-} [list 1 "invalid sash index" 1 "invalid sash index" 1 "invalid sash index"]
-test panedwindow-6.9 {sash coord subcommand, errors} {
+ list [catch {.p sash coord -1} msg] $msg \
+ [catch {.p sash coord 0} msg] $msg \
+ [catch {.p sash coord 1} msg] $msg
+} -cleanup {
+ deleteWindows
+} -result [list 1 "invalid sash index" 1 "invalid sash index" 1 "invalid sash index"]
+test panedwindow-6.9 {sash coord subcommand, errors} -setup {
+ deleteWindows
+} -body {
# There are no sashes until you have 2 panes
panedwindow .p
.p add [frame .p.f]
- set result [list \
- [catch {.p sash coord -1} msg] $msg \
+ list [catch {.p sash coord -1} msg] $msg \
[catch {.p sash coord 0} msg] $msg \
- [catch {.p sash coord 1} msg] $msg \
- ]
- destroy .p
- set result
-} [list 1 "invalid sash index" 1 "invalid sash index" 1 "invalid sash index"]
-test panedwindow-6.10 {sash coord subcommand, errors} {
+ [catch {.p sash coord 1} msg] $msg
+} -cleanup {
+ deleteWindows
+} -result [list 1 "invalid sash index" 1 "invalid sash index" 1 "invalid sash index"]
+test panedwindow-6.10 {sash coord subcommand, errors} -setup {
+ deleteWindows
+} -body {
# There are no sashes until you have 2 panes
panedwindow .p
.p add [frame .p.f] [frame .p.f2]
- set result [list \
- [catch {.p sash coord -1} msg] $msg \
+ list [catch {.p sash coord -1} msg] $msg \
[catch {.p sash coord 0} msg] \
[catch {.p sash coord 1} msg] $msg \
- [catch {.p sash coord 2} msg] $msg \
- ]
- destroy .p
- set result
-} [list 1 "invalid sash index" 0 1 "invalid sash index" 1 "invalid sash index"]
+ [catch {.p sash coord 2} msg] $msg
+} -cleanup {
+ deleteWindows
+} -result [list 1 "invalid sash index" 0 1 "invalid sash index" 1 "invalid sash index"]
+
-test panedwindow-8.1 {sash mark subcommand, errors} {
+test panedwindow-7.1 {sash mark subcommand, errors} -setup {
+ deleteWindows
+} -body {
panedwindow .p
- set result [list [catch {.p sash mark} msg] $msg]
- destroy .p
- set result
-} [list 1 "wrong # args: should be \".p sash mark index ?x y?\""]
-test panedwindow-8.2 {sash mark subcommand, errors} {
+ .p sash mark
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {wrong # args: should be ".p sash mark index ?x y?"}
+test panedwindow-7.2 {sash mark subcommand, errors} -setup {
+ deleteWindows
+} -body {
panedwindow .p
- set result [list [catch {.p sash mark foo} msg] $msg]
- destroy .p
- set result
-} [list 1 "expected integer but got \"foo\""]
-test panedwindow-8.3 {sash mark subcommand, errors} {
+ .p sash mark foo
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "foo"}
+test panedwindow-7.3 {sash mark subcommand, errors} -setup {
+ deleteWindows
+} -body {
panedwindow .p
- set result [list [catch {.p sash mark 0 foo bar} msg] $msg]
- destroy .p
- set result
-} [list 1 "invalid sash index"]
-test panedwindow-8.4 {sash mark subcommand, errors} {
+ .p sash mark 0 foo bar
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {invalid sash index}
+test panedwindow-7.4 {sash mark subcommand, errors} -setup {
+ deleteWindows
+} -body {
panedwindow .p
.p add [button .b] [button .c]
- set result [list [catch {.p sash mark 0 foo bar} msg] $msg]
- destroy .p .b .c
- set result
-} [list 1 "expected integer but got \"foo\""]
-test panedwindow-8.5 {sash mark subcommand, errors} {
+ .p sash mark 0 foo bar
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "foo"}
+test panedwindow-7.5 {sash mark subcommand, errors} -setup {
+ deleteWindows
+} -body {
panedwindow .p
.p add [button .b] [button .c]
- set result [list [catch {.p sash mark 0 0 bar} msg] $msg]
- destroy .p .b .c
- set result
-} [list 1 "expected integer but got \"bar\""]
-test panedwindow-8.6 {sash mark subcommand, mark defaults to 0 0} {
+ .p sash mark 0 0 bar
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "bar"}
+test panedwindow-7.6 {sash mark subcommand, mark defaults to 0 0} -setup {
+ deleteWindows
+} -body {
panedwindow .p
.p add [button .b] [button .c]
- set result [.p sash mark 0]
- destroy .p .b .c
- set result
-} [list 0 0]
-test panedwindow-8.7 {sash mark subcommand, set mark} {
+ .p sash mark 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 0]
+test panedwindow-7.7 {sash mark subcommand, set mark} -setup {
+ deleteWindows
+} -body {
panedwindow .p
.p add [button .b] [button .c]
.p sash mark 0 10 10
- set result [.p sash mark 0]
- destroy .p .b .c
- set result
-} [list 10 10]
+ .p sash mark 0
+} -cleanup {
+ deleteWindows
+} -result [list 10 10]
+
-test panedwindow-9.1 {sash dragto subcommand, errors} {
+test panedwindow-8.1 {sash dragto subcommand, errors} -setup {
+ deleteWindows
+} -body {
panedwindow .p
- set result [list [catch {.p sash dragto} msg] $msg]
- destroy .p
- set result
-} [list 1 "wrong # args: should be \".p sash dragto index x y\""]
-test panedwindow-9.2 {sash dragto subcommand, errors} {
+ .p sash dragto
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {wrong # args: should be ".p sash dragto index x y"}
+test panedwindow-8.2 {sash dragto subcommand, errors} -setup {
+ deleteWindows
+} -body {
panedwindow .p
- set result [list [catch {.p sash dragto foo bar baz} msg] $msg]
- destroy .p
- set result
-} [list 1 "expected integer but got \"foo\""]
-test panedwindow-9.3 {sash dragto subcommand, errors} {
+ .p sash dragto foo bar baz
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "foo"}
+test panedwindow-8.3 {sash dragto subcommand, errors} -setup {
+ deleteWindows
+} -body {
panedwindow .p
- set result [list [catch {.p sash dragto 0 foo bar} msg] $msg]
- destroy .p
- set result
-} [list 1 "invalid sash index"]
-test panedwindow-9.4 {sash dragto subcommand, errors} {
+ .p sash dragto 0 foo bar
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {invalid sash index}
+test panedwindow-8.4 {sash dragto subcommand, errors} -setup {
+ deleteWindows
+} -body {
panedwindow .p
.p add [button .b] [button .c]
- set result [list [catch {.p sash dragto 0 foo bar} msg] $msg]
- destroy .p .b .c
- set result
-} [list 1 "expected integer but got \"foo\""]
-test panedwindow-9.5 {sash dragto subcommand, errors} {
+ .p sash dragto 0 foo bar
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "foo"}
+test panedwindow-8.5 {sash dragto subcommand, errors} -setup {
+ deleteWindows
+} -body {
panedwindow .p
.p add [button .b] [button .c]
- set result [list [catch {.p sash dragto 0 0 bar} msg] $msg]
- destroy .p .b .c
- set result
-} [list 1 "expected integer but got \"bar\""]
+ .p sash dragto 0 0 bar
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "bar"}
-test panedwindow-10.1 {sash mark/sash dragto interaction} {
+
+test panedwindow-9.1 {sash mark/sash dragto interaction} -setup {
+ deleteWindows
+} -body {
panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -showhandle false
.p add [frame .f -width 20 -height 20] [button .c -text foobar]
.p sash mark 0 10 10
.p sash dragto 0 20 10
- set result [.p sash coord 0]
- destroy .p .f .c
- set result
-} [list 30 0]
-test panedwindow-10.2 {sash mark/sash dragto interaction} {
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 30 0]
+test panedwindow-9.2 {sash mark/sash dragto interaction} -setup {
+ deleteWindows
+} -body {
panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -orient vertical \
-showhandle false
.p add [frame .p.f -width 20 -height 20] [button .p.c -text foobar]
.p sash mark 0 10 10
.p sash dragto 0 10 20
- set result [.p sash coord 0]
- destroy .p .p.f .p.c
- set result
-} [list 0 30]
-test panedwindow-10.3 {sash mark/sash dragto, respects minsize} {
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 30]
+test panedwindow-9.3 {sash mark/sash dragto, respects minsize} -setup {
+ deleteWindows
+} -body {
panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -showhandle false
.p add [frame .f -width 20 -height 20] [button .c] -minsize 15
.p sash mark 0 20 10
.p sash dragto 0 10 10
- set result [.p sash coord 0]
- destroy .p .f .c
- set result
-} [list 15 0]
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 15 0]
+
-test panedwindow-11.1 {sash place subcommand, errors} {
+test panedwindow-10.1 {sash place subcommand, errors} -setup {
+ deleteWindows
+} -body {
panedwindow .p
- set result [list [catch {.p sash place} msg] $msg]
- destroy .p
- set result
-} [list 1 "wrong # args: should be \".p sash place index x y\""]
-test panedwindow-11.2 {sash place subcommand, errors} {
- destroy .p
+ .p sash place
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {wrong # args: should be ".p sash place index x y"}
+test panedwindow-10.2 {sash place subcommand, errors} -setup {
+ deleteWindows
+} -body {
panedwindow .p
- list [catch {.p sash place foo bar baz} msg] $msg
-} [list 1 "expected integer but got \"foo\""]
-test panedwindow-11.3 {sash place subcommand, errors} {
- destroy .p
+ .p sash place foo bar baz
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "foo"}
+test panedwindow-10.3 {sash place subcommand, errors} -setup {
+ deleteWindows
+} -body {
panedwindow .p
- list [catch {.p sash place 0 foo bar} msg] $msg
-} [list 1 "invalid sash index"]
-test panedwindow-11.4 {sash place subcommand, errors} {
- destroy .p .b .c
+ .p sash place 0 foo bar
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {invalid sash index}
+test panedwindow-10.4 {sash place subcommand, errors} -setup {
+ deleteWindows
+} -body {
panedwindow .p
.p add [button .b] [button .c]
- list [catch {.p sash place 0 foo bar} msg] $msg
-} [list 1 "expected integer but got \"foo\""]
-test panedwindow-11.5 {sash place subcommand, errors} {
- destroy .p .f .c .b
+ .p sash place 0 foo bar
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "foo"}
+test panedwindow-10.5 {sash place subcommand, errors} -setup {
+ deleteWindows
+} -body {
panedwindow .p
.p add [button .b] [button .c]
- list [catch {.p sash place 0 0 bar} msg] $msg
-} [list 1 "expected integer but got \"bar\""]
-test panedwindow-11.6 {sash place subcommand, moves sash} {
- destroy .p .f .c .b
+ .p sash place 0 0 bar
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "bar"}
+test panedwindow-10.6 {sash place subcommand, moves sash} -setup {
+ deleteWindows
+} -body {
panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4
.p add [frame .f -width 20 -height 20] [button .c]
.p sash place 0 10 0
.p sash coord 0
-} [list 10 0]
-test panedwindow-11.7 {sash place subcommand, moves sash} {
- destroy .p .f .c
+} -cleanup {
+ deleteWindows
+} -result [list 10 0]
+test panedwindow-10.7 {sash place subcommand, moves sash} -setup {
+ deleteWindows
+} -body {
panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -orient vertical
.p add [frame .f -width 20 -height 20] [button .c]
.p sash place 0 0 10
.p sash coord 0
-} [list 0 10]
-test panedwindow-11.8 {sash place subcommand, respects minsize} {
- destroy .p .f .c
+} -cleanup {
+ deleteWindows
+} -result [list 0 10]
+test panedwindow-10.8 {sash place subcommand, respects minsize} -setup {
+ deleteWindows
+} -body {
panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -showhandle false
.p add [frame .f -width 20 -height 20] [button .c] -minsize 15
.p sash place 0 10 0
.p sash coord 0
-} [list 15 0]
-test panedwindow-11.9 {sash place subcommand, respects minsize} {
- destroy .p .f .c
+} -cleanup {
+ deleteWindows
+} -result [list 15 0]
+test panedwindow-10.9 {sash place subcommand, respects minsize} -setup {
+ deleteWindows
+} -body {
panedwindow .p
.p add [frame .f -width 20 -height 20 -bg pink]
- list [catch {.p sash place 0 2 0} msg] $msg
-} [list 1 {invalid sash index}]
+ .p sash place 0 2 0
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {invalid sash index}
+
-test panedwindow-12.1 {moving sash changes size of pane to left} {
- destroy .p .f .c
+test panedwindow-11.1 {moving sash changes size of pane to left} -setup {
+ deleteWindows
+} -body {
panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -showhandle false
.p add [frame .f -width 20 -height 20] [button .c -text foobar] -sticky nsew
.p sash place 0 30 0
pack .p
update
winfo width .f
-} 30
-test panedwindow-12.2 {moving sash changes size of pane to right} {
- destroy .p .f .f2
+} -result 30
+test panedwindow-11.2 {moving sash changes size of pane to right} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4
.p add [frame .f -width 20 -height 20] [frame .f2 -width 20 -height 20]
pack .p
@@ -462,16 +737,20 @@ test panedwindow-12.2 {moving sash changes size of pane to right} {
.p sash place 0 30 0
update
lappend result [winfo width .f2]
-} {20 10}
-test panedwindow-12.3 {moving sash does not change reqsize of panedwindow} {
- destroy .p .f .f2
+} -cleanup {
+ deleteWindows
+} -result {20 10}
+test panedwindow-11.3 {moving sash does not change reqsize of panedwindow} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4
.p add [frame .f -width 20 -height 20] [frame .f2 -width 20 -height 20]
.p sash place 0 30 0
winfo reqwidth .p
-} 44
-test panedwindow-12.4 {moving sash changes size of pane above} {
- destroy .p .f .c
+} -result 44
+test panedwindow-11.4 {moving sash changes size of pane above} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \
-orient vertical
.p add [frame .f -width 20 -height 10] [button .c -text foobar] -sticky nsew
@@ -479,11 +758,11 @@ test panedwindow-12.4 {moving sash changes size of pane above} {
pack .p
update
set result [winfo height .f]
- destroy .p .f .c
set result
-} 20
-test panedwindow-12.5 {moving sash changes size of pane below} {
- destroy .p .f .f2
+} -result 20
+test panedwindow-11.5 {moving sash changes size of pane below} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \
-orient vertical
.p add [frame .f -width 20 -height 10] [frame .f2 -width 20 -height 10]
@@ -493,81 +772,92 @@ test panedwindow-12.5 {moving sash changes size of pane below} {
.p sash place 0 0 15
update
lappend result [winfo height .f2]
- destroy .p .f .f2
set result
-} {10 5}
-test panedwindow-12.6 {moving sash does not change reqsize of panedwindow} {
+} -cleanup {
+ deleteWindows
+} -result {10 5}
+test panedwindow-11.6 {moving sash does not change reqsize of panedwindow} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \
-orient vertical
.p add [frame .f -width 20 -height 10] [frame .f2 -width 20 -height 10]
set result [winfo reqheight .p]
.p sash place 0 0 20
lappend result [winfo reqheight .p]
- destroy .p .f .f2
set result
-} [list 24 24]
-test panedwindow-12.7 {moving sash does not alter reqsize of widget} {
- destroy .p .f .f2
+} -cleanup {
+ deleteWindows
+} -result [list 24 24]
+test panedwindow-11.7 {moving sash does not alter reqsize of widget} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \
-orient vertical
.p add [frame .f -width 20 -height 10] [frame .f2 -width 20 -height 10]
set result [winfo reqheight .f]
.p sash place 0 0 20
lappend result [winfo reqheight .f]
- destroy .p .f .f2
- set result
-} [list 10 10]
-test panedwindow-12.8 {moving sash restricted to minsize} {
- destroy .p .f .c
+} -cleanup {
+ deleteWindows
+} -result [list 10 10]
+test panedwindow-11.8 {moving sash restricted to minsize} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4
.p add [frame .f -width 20 -height 20] [button .c] -minsize 15
.p sash place 0 10 0
pack .p
update
- set result [winfo width .f]
- destroy .p .f .c
- set result
-} 15
-test panedwindow-12.10 {moving sash restricted to minsize} {
- destroy .p .f .c
+ winfo width .f
+} -result 15
+test panedwindow-11.9 {moving sash restricted to minsize} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \
-orient vertical
.p add [frame .f -width 20 -height 30] [button .c] -minsize 10
.p sash place 0 0 5
pack .p
update
- set result [winfo height .f]
- destroy .p .f .c
- set result
-} 10
-test panedwindow-12.12 {moving sash in unmapped window restricted to reqsize} {
+ winfo height .f
+} -result 10
+test panedwindow-11.10 {moving sash in unmapped window restricted to reqsize} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4
.p add [frame .f -width 20 -height 30] [frame .f2 -width 20 -height 20]
set result [list [.p sash coord 0]]
.p sash place 0 100 0
lappend result [.p sash coord 0]
- destroy .p .f .f2
- set result
-} [list {20 0} {40 0}]
-test panedwindow-12.13 {moving sash right pushes other sashes} {
+} -cleanup {
+ deleteWindows
+} -result [list {20 0} {40 0}]
+test panedwindow-11.11 {moving sash right pushes other sashes} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4
.p add [frame .f -width 20 -height 30] [frame .f2 -width 20 -height 20] \
[frame .f3 -width 20 -height 30]
.p sash place 0 80 0
- set result [list [.p sash coord 0] [.p sash coord 1]]
- destroy .p .f .f2 .f3
- set result
-} {{60 0} {64 0}}
-test panedwindow-12.14 {moving sash left pushes other sashes} {
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{60 0} {64 0}}
+test panedwindow-11.12 {moving sash left pushes other sashes} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4
.p add [frame .f -width 20 -height 30] [frame .f2 -width 20 -height 20] \
[frame .f3 -width 20 -height 30]
.p sash place 1 0 0
- set result [list [.p sash coord 0] [.p sash coord 1]]
- destroy .p .f .f2 .f3
- set result
-} {{0 0} {4 0}}
-test panedwindow-12.15 {move sash in mapped window restricted to visible win} {
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{0 0} {4 0}}
+test panedwindow-11.13 {move sash in mapped window restricted to visible win} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4
.p add [frame .f -width 20 -height 30] [frame .f2 -width 20 -height 20] \
[frame .f3 -width 20 -height 30]
@@ -575,11 +865,13 @@ test panedwindow-12.15 {move sash in mapped window restricted to visible win} {
update
.p sash place 1 100 0
update
- set result [.p sash coord 1]
- destroy .p .f .f2 .f3
- set result
-} {46 0}
-test panedwindow-12.16 {move sash in mapped window restricted to visible win} {
+ .p sash coord 1
+} -cleanup {
+ deleteWindows
+} -result {46 0}
+test panedwindow-11.14 {move sash in mapped window restricted to visible win} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4
.p add [frame .f -width 20 -height 30] [frame .f2 -width 20 -height 20] \
[frame .f3 -width 20 -height 30]
@@ -587,12 +879,13 @@ test panedwindow-12.16 {move sash in mapped window restricted to visible win} {
update
.p sash place 1 200 0
update
- set result [.p sash coord 1]
- destroy .p .f .f2 .f3
- set result
-} {96 0}
-test panedwindow-12.17 {moving sash into "virtual" space on \
- last pane increases reqsize} {
+ .p sash coord 1
+} -cleanup {
+ deleteWindows
+} -result {96 0}
+test panedwindow-11.15 {moving sash into "virtual" space on last pane increases reqsize} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4
.p add [frame .f -width 20 -height 30] [frame .f2 -width 20 -height 20] \
[frame .f3 -width 20 -height 30]
@@ -602,36 +895,45 @@ test panedwindow-12.17 {moving sash into "virtual" space on \
.p sash place 1 200 0
update
lappend result [winfo reqwidth .p]
- destroy .p .f .f2 .f3
- set result
-} {68 100}
+} -cleanup {
+ deleteWindows
+} -result {68 100}
-test panedwindow-13.1 {horizontal panedwindow lays out widgets properly} {
+
+test panedwindow-12.1 {horizontal panedwindow lays out widgets properly} -setup {
+ deleteWindows
+ set result {}
+} -body {
panedwindow .p -showhandle false -borderwidth 2 -sashpad 2 -sashwidth 2
foreach win {.p.f .p.f2 .p.f3} {.p add [frame $win -width 20 -height 10]}
pack .p
update
- set result {}
foreach w [.p panes] {lappend result [winfo x $w] [winfo y $w]}
- destroy .p .p.f .p.f2 .p.f3
- set result
-} [list 2 2 28 2 54 2]
-test panedwindow-13.2 {vertical panedwindow lays out widgets properly} {
+ return $result
+} -cleanup {
+ deleteWindows
+} -result [list 2 2 28 2 54 2]
+test panedwindow-12.2 {vertical panedwindow lays out widgets properly} -setup {
+ deleteWindows
+ set result {}
+} -body {
panedwindow .p -showhandle false -borderwidth 2 -sashpad 2 -sashwidth 2 \
-orient vertical
foreach win {.p.f .p.f2 .p.f3} {.p add [frame $win -width 20 -height 10]}
pack .p
update
- set result {}
foreach w [.p panes] {lappend result [winfo x $w] [winfo y $w]}
- destroy .p .p.f .p.f2 .p.f3
- set result
-} [list 2 2 2 18 2 34]
-test panedwindow-13.3 {horizontal panedwindow lays out widgets properly} {
+ return $result
+} -cleanup {
+ deleteWindows
+} -result [list 2 2 2 18 2 34]
+test panedwindow-12.3 {horizontal panedwindow lays out widgets properly} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
foreach {win color} {.p.f blue .p.f2 green} {
- .p add [frame $win -width 20 -height 20 -bg $color] -padx 10 -pady 5 \
- -sticky ""
+ .p add [frame $win -width 20 -height 20 -bg $color] -padx 10 -pady 5 \
+ -sticky ""
}
pack .p
update
@@ -641,10 +943,13 @@ test panedwindow-13.3 {horizontal panedwindow lays out widgets properly} {
update
lappend result [winfo reqwidth .p] [winfo reqheight .p]
foreach win {.p.f .p.f2} {lappend result [winfo x $win] [winfo y $win]}
- destroy .p .p.f .p.f2
- set result
-} [list 80 30 10 5 50 5 60 30 0 5 30 5]
-test panedwindow-13.4 {vertical panedwindow lays out widgets properly} {
+ return $result
+} -cleanup {
+ deleteWindows
+} -result [list 80 30 10 5 50 5 60 30 0 5 30 5]
+test panedwindow-12.4 {vertical panedwindow lays out widgets properly} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 \
-orient vertical
foreach win {.p.f .p.f2} {
@@ -658,10 +963,13 @@ test panedwindow-13.4 {vertical panedwindow lays out widgets properly} {
update
lappend result [winfo reqwidth .p] [winfo reqheight .p]
foreach win {.p.f .p.f2} {lappend result [winfo x $win] [winfo y $win]}
- destroy .p .p.f .p.f2
- set result
-} [list 40 60 10 5 10 35 40 50 10 0 10 25]
-test panedwindow-13.5 {panedwindow respects reqsize of panes when possible} {
+ return $result
+} -cleanup {
+ deleteWindows
+} -result [list 40 60 10 5 10 35 40 50 10 0 10 25]
+test panedwindow-12.5 {panedwindow respects reqsize of panes when possible} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
.p add [frame .p.f -width 20 -height 20] -sticky ""
place .p -width 40
@@ -670,10 +978,12 @@ test panedwindow-13.5 {panedwindow respects reqsize of panes when possible} {
.p.f configure -width 30
update
lappend result [winfo width .p.f]
- destroy .p .p.f
- set result
-} [list 20 30]
-test panedwindow-13.6 {panedwindow takes explicit widget width over reqwidth} {
+} -cleanup {
+ deleteWindows
+} -result [list 20 30]
+test panedwindow-12.6 {panedwindow takes explicit widget width over reqwidth} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
.p add [frame .p.f -width 20 -height 20] -width 20 -sticky ""
place .p -width 40
@@ -682,29 +992,35 @@ test panedwindow-13.6 {panedwindow takes explicit widget width over reqwidth} {
.p.f configure -width 30
update
lappend result [winfo width .p.f]
- destroy .p .p.f
- set result
-} [list 20 20]
-test panedwindow-13.7 {horizontal panedwindow reqheight is max slave height} {
+} -cleanup {
+ deleteWindows
+} -result [list 20 20]
+test panedwindow-12.7 {horizontal panedwindow reqheight is max slave height} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4
.p add [frame .p.f -width 20 -height 20] [frame .p.f2 -width 20 -height 20]
set result [winfo reqheight .p]
.p.f config -height 40
lappend result [winfo reqheight .p]
- destroy .p .p.f .p.f2
- set result
-} {20 40}
-test panedwindow-13.8 {horizontal panedwindow reqheight is max slave height} {
+} -cleanup {
+ deleteWindows
+} -result {20 40}
+test panedwindow-12.8 {horizontal panedwindow reqheight is max slave height} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4
foreach win {.p.f .p.f2} {.p add [frame $win -width 20 -height 20]}
.p paneconfigure .p.f -height 15
set result [winfo reqheight .p]
.p.f config -height 40
lappend result [winfo reqheight .p]
- destroy .p .p.f .p.f2
- set result
-} {20 20}
-test panedwindow-13.9 {panedwindow pane width overrides widget width} {
+} -cleanup {
+ deleteWindows
+} -result {20 20}
+test panedwindow-12.9 {panedwindow pane width overrides widget width} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4
foreach win {.p.f .p.f2} {.p add [frame $win -width 20 -height 20]}
.p sash place 0 10 0
@@ -713,10 +1029,12 @@ test panedwindow-13.9 {panedwindow pane width overrides widget width} {
set result [winfo width .p.f]
.p paneconfigure .p.f -width 30
lappend result [winfo width .p.f]
- destroy .p .p.f .p.f2
- set result
-} [list 10 10]
-test panedwindow-13.10 {panedwindow respects reqsize of panes when possible} {
+} -cleanup {
+ deleteWindows
+} -result [list 10 10]
+test panedwindow-12.10 {panedwindow respects reqsize of panes when possible} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
.p add [frame .p.f -width 20 -height 20] -sticky ""
place .p -height 40
@@ -725,10 +1043,12 @@ test panedwindow-13.10 {panedwindow respects reqsize of panes when possible} {
.p.f configure -height 30
update
lappend result [winfo height .p.f]
- destroy .p .p.f
- set result
-} [list 20 30]
-test panedwindow-13.11 {panedwindow takes explicit height over reqheight} {
+} -cleanup {
+ deleteWindows
+} -result [list 20 30]
+test panedwindow-12.11 {panedwindow takes explicit height over reqheight} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
.p add [frame .p.f -width 20 -height 20] -height 20 -sticky ""
place .p -height 40
@@ -737,20 +1057,24 @@ test panedwindow-13.11 {panedwindow takes explicit height over reqheight} {
.p.f configure -height 30
update
lappend result [winfo height .p.f]
- destroy .p .p.f
- set result
-} [list 20 20]
-test panedwindow-13.12 {vertical panedwindow reqwidth is max slave width} {
+} -cleanup {
+ deleteWindows
+} -result [list 20 20]
+test panedwindow-12.12 {vertical panedwindow reqwidth is max slave width} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \
-orient vertical
.p add [frame .p.f -width 20 -height 20] [frame .p.f2 -width 20 -height 20]
set result [winfo reqwidth .p]
.p.f config -width 40
lappend result [winfo reqwidth .p]
- destroy .p .p.f .p.f2
- set result
-} {20 40}
-test panedwindow-13.13 {vertical panedwindow reqwidth is max slave width} {
+} -cleanup {
+ deleteWindows
+} -result {20 40}
+test panedwindow-12.13 {vertical panedwindow reqwidth is max slave width} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \
-orient vertical
foreach win {.p.f .p.f2} {.p add [frame $win -width 20 -height 20]}
@@ -758,11 +1082,12 @@ test panedwindow-13.13 {vertical panedwindow reqwidth is max slave width} {
set result [winfo reqwidth .p]
.p.f config -width 40
lappend result [winfo reqwidth .p]
- destroy .p .p.f .p.f2
- set result
-} {20 20}
-test panedwindow-13.14 {panedwindow pane height overrides widget width} {
- destroy .p
+} -cleanup {
+ deleteWindows
+} -result {20 20}
+test panedwindow-12.14 {panedwindow pane height overrides widget width} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \
-orient vertical
foreach win {.p.f .p.f2} {.p add [frame $win -width 20 -height 20]}
@@ -772,32 +1097,34 @@ test panedwindow-13.14 {panedwindow pane height overrides widget width} {
set result [winfo height .p.f]
.p paneconfigure .p.f -height 30
lappend result [winfo height .p.f]
- destroy .p
- set result
-} [list 10 10]
+} -cleanup {
+ deleteWindows
+} -result [list 10 10]
-test panedwindow-14.1 {PanestructureProc, widget yields managements} {
+test panedwindow-13.1 {PanestructureProc, widget yields managements} -setup {
+ deleteWindows
+} -body {
# Check that the panedwindow correctly yields geometry management of
# a slave when the slave is destroyed.
# This test should not cause a core dump, and it should not cause
# a memory leak.
- destroy .p .b
panedwindow .p
.p add [button .b]
destroy .p
pack .b
destroy .b
set result ""
-} ""
-test panedwindow-14.2 {PanedWindowLostSlaveProc, widget yields management} {
+} -result {}
+test panedwindow-13.2 {PanedWindowLostSlaveProc, widget yields management} -setup {
+ deleteWindows
+} -body {
# Check that the paned window correctly yields geometry management of
# a slave when some other geometry manager steals the slave from us.
# This test should not cause a core dump, and it should not cause a
# memory leak.
- destroy .p .b
panedwindow .p
.p add [button .b]
pack .p
@@ -807,56 +1134,359 @@ test panedwindow-14.2 {PanedWindowLostSlaveProc, widget yields management} {
set result [.p panes]
destroy .p .b
set result
-} {}
-
-set stickysets [list n s e w sn ns en ne wn nw esn nse nsw nsew ""]
-set stickygets [list n s e w ns ns ne ne nw nw nes nes nsw nesw ""]
-set i 0
-foreach s $stickysets g $stickygets {
- test panedwindow-15.[incr i] {panedwindow sticky settings} {
- destroy .p .b
- panedwindow .p -showhandle false
- .p add [button .b]
- .p paneconfigure .b -sticky $s
- set result [.p panecget .b -sticky]
- destroy .p .b
- set result
- } $g
-}
-
-set i 0
-foreach s [list {} n s e w ns ew nw ne se sw nse nsw sew new news] \
- x [list 10 10 10 20 0 10 0 0 20 20 0 20 0 0 0 0] \
- y [list 10 0 20 10 10 0 10 0 0 20 20 0 0 20 0 0] \
- w [list 20 20 20 20 20 20 40 20 20 20 20 20 20 40 40 40] \
- h [list 20 20 20 20 20 40 20 20 20 20 20 40 40 20 20 40] {
- test panedwindow-16.[incr i] {panedwindow sticky works} {
- panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
- .p add [frame .p.f -height 20 -width 20 -bg red] -sticky $s
- place .p -width 40 -height 40
- update
- set result [list $s [winfo x .p.f] [winfo y .p.f] \
- [winfo width .p.f] [winfo height .p.f]]
- destroy .p .p.f
- set result
- } [list $s $x $y $w $h]
-}
-
-test panedwindow-17.1 {setting minsize when pane is too small snaps width} {
+} -result {}
+
+
+test panedwindow-14.1 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky n
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {n}
+test panedwindow-14.2 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky s
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {s}
+test panedwindow-14.3 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky e
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {e}
+test panedwindow-14.4 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky w
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {w}
+test panedwindow-14.5 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky sn
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {ns}
+test panedwindow-14.6 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky ns
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {ns}
+test panedwindow-14.7 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky en
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {ne}
+test panedwindow-14.8 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky ne
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {ne}
+test panedwindow-14.9 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky wn
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {nw}
+test panedwindow-14.10 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky nw
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {nw}
+test panedwindow-14.11 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky esn
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {nes}
+test panedwindow-14.12 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky nse
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {nes}
+test panedwindow-14.13 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky nsw
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {nsw}
+test panedwindow-14.14 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky nsew
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {nesw}
+test panedwindow-14.15 {panedwindow sticky settings} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false
+ .p add [button .b]
+ .p paneconfigure .b -sticky ""
+ .p panecget .b -sticky
+} -cleanup {
+ deleteWindows
+} -result {}
+
+
+test panedwindow-15.1 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky {}
+ place .p -width 40 -height 40
+ update
+ list {} [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {{} 10 10 20 20}
+test panedwindow-15.2 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky n
+ place .p -width 40 -height 40
+ update
+ list n [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {n 10 0 20 20}
+test panedwindow-15.3 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky s
+ place .p -width 40 -height 40
+ update
+ list s [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {s 10 20 20 20}
+test panedwindow-15.4 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky e
+ place .p -width 40 -height 40
+ update
+ list e [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {e 20 10 20 20}
+test panedwindow-15.5 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky w
+ place .p -width 40 -height 40
+ update
+ list w [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {w 0 10 20 20}
+test panedwindow-15.6 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky ns
+ place .p -width 40 -height 40
+ update
+ list ns [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {ns 10 0 20 40}
+test panedwindow-15.7 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky ew
+ place .p -width 40 -height 40
+ update
+ list ew [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {ew 0 10 40 20}
+test panedwindow-15.8 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky nw
+ place .p -width 40 -height 40
+ update
+ list nw [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {nw 0 0 20 20}
+test panedwindow-15.9 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky ne
+ place .p -width 40 -height 40
+ update
+ list ne [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {ne 20 0 20 20}
+test panedwindow-15.10 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky se
+ place .p -width 40 -height 40
+ update
+ list se [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {se 20 20 20 20}
+test panedwindow-15.11 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky sw
+ place .p -width 40 -height 40
+ update
+ list sw [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {sw 0 20 20 20}
+test panedwindow-15.12 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky nse
+ place .p -width 40 -height 40
+ update
+ list nse [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {nse 20 0 20 40}
+test panedwindow-15.13 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky nsw
+ place .p -width 40 -height 40
+ update
+ list nsw [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {nsw 0 0 20 40}
+test panedwindow-15.14 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky sew
+ place .p -width 40 -height 40
+ update
+ list sew [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {sew 0 20 40 20}
+test panedwindow-15.15 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky new
+ place .p -width 40 -height 40
+ update
+ list new [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {new 0 0 40 20}
+test panedwindow-15.16 {panedwindow sticky works} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
+ .p add [frame .p.f -height 20 -width 20 -bg red] -sticky news
+ place .p -width 40 -height 40
+ update
+ list news [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f]
+} -cleanup {
+ deleteWindows
+} -result {news 0 0 40 40}
+
+
+test panedwindow-16.1 {setting minsize when pane is too small snaps width} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
.p add [frame .p.f -height 20 -width 20 -bg red]
set result [winfo reqwidth .p]
.p paneconfigure .p.f -minsize 40
lappend result [winfo reqwidth .p]
- destroy .p .p.f .p.f2
- set result
-} [list 20 40]
+} -cleanup {
+ deleteWindows
+} -result [list 20 40]
+
-test panedwindow-18.1 {MoveSash, move right} {
+test panedwindow-17.1 {MoveSash, move right} -setup {
+ deleteWindows
set result {}
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
foreach w {.f1 .f2} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
}
# Get the requested width of the paned window
@@ -869,33 +1499,31 @@ test panedwindow-18.1 {MoveSash, move right} {
# Check that the sash moved
lappend result [.p sash coord 0]
-
- # Cleanup
- destroy .p .f1 .f2
-
- set result
-} [list 42 42 {30 0}]
-test panedwindow-18.2 {MoveSash, move right (unmapped) clipped by reqwidth} {
+} -cleanup {
+ deleteWindows
+} -result [list 42 42 {30 0}]
+test panedwindow-17.2 {MoveSash, move right (unmapped) clipped by reqwidth} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
foreach w {.f1 .f2} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
}
.p sash place 0 100 0
# Get the new sash coord; it should be clipped by the reqwidth of
# the panedwindow.
- set result [.p sash coord 0]
-
- # Cleanup
- destroy .p .f1 .f2
-
- set result
-} [list 40 0]
-test panedwindow-18.3 {MoveSash, move right (mapped, width < reqwidth) clipped by width} {
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 40 0]
+test panedwindow-17.3 {MoveSash, move right (mapped, width < reqwidth) clipped by width} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
foreach w {.f1 .f2} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
}
# Put the panedwindow up on the display and give it a width < reqwidth
@@ -906,17 +1534,16 @@ test panedwindow-18.3 {MoveSash, move right (mapped, width < reqwidth) clipped b
# Get the new sash coord; it should be clipped by the visible width of
# the panedwindow.
- set result [.p sash coord 0]
-
- # Cleanup
- destroy .p .f1 .f2
-
- set result
-} [list 30 0]
-test panedwindow-18.4 {MoveSash, move right (mapped, width > reqwidth) clipped by width} {
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 30 0]
+test panedwindow-17.4 {MoveSash, move right (mapped, width > reqwidth) clipped by width} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
foreach w {.f1 .f2} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
}
# Put the panedwindow up on the display and give it a width > reqwidth
@@ -927,121 +1554,114 @@ test panedwindow-18.4 {MoveSash, move right (mapped, width > reqwidth) clipped b
# Get the new sash coord; it should be clipped by the visible width of
# the panedwindow.
- set result [.p sash coord 0]
-
- # Cleanup
- destroy .p .f1 .f2
-
- set result
-} [list 100 0]
-test panedwindow-18.5 {MoveSash, move right respects minsize} {
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 100 0]
+test panedwindow-17.5 {MoveSash, move right respects minsize} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
foreach w {.f1 .f2} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
}
.p sash place 0 100 0
# Get the new sash coord; it should have moved as far as possible while
# respecting minsizes.
- set result [.p sash coord 0]
-
- # Cleanup
- destroy .p .f1 .f2
-
- set result
-} [list 30 0]
-test panedwindow-18.6 {MoveSash, move right respects minsize} {
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 30 0]
+test panedwindow-17.6 {MoveSash, move right respects minsize} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
foreach w {.f1 .f2 .f3} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
}
.p sash place 0 100 0
# Get the new sash coord; it should have moved as far as possible.
- set result [.p sash coord 0]
-
- # Cleanup
- destroy .p .f1 .f2 .f3
-
- set result
-} [list 40 0]
-test panedwindow-18.7 {MoveSash, move right pushes other sashes} {
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 40 0]
+test panedwindow-17.7 {MoveSash, move right pushes other sashes} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
foreach w {.f1 .f2 .f3} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
}
.p sash place 0 100 0
# Get the new sash coord; it should have moved as far as possible while
# respecting minsizes.
- set result [.p sash coord 1]
-
- # Cleanup
- destroy .p .f1 .f2 .f3
-
- set result
-} [list 62 0]
-test panedwindow-18.8 {MoveSash, move right pushes other sashes, respects minsize} {
+ .p sash coord 1
+} -cleanup {
+ deleteWindows
+} -result [list 62 0]
+test panedwindow-17.8 {MoveSash, move right pushes other sashes, respects minsize} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
foreach w {.f1 .f2 .f3} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
}
.p sash place 0 100 0
# Get the new sash coord; it should have moved as far as possible while
# respecting minsizes.
- set result [.p sash coord 1]
-
- # Cleanup
- destroy .p .f1 .f2 .f3
-
- set result
-} [list 52 0]
-test panedwindow-18.9 {MoveSash, move right respects minsize, exludes pad} {
+ .p sash coord 1
+} -cleanup {
+ deleteWindows
+} -result [list 52 0]
+test panedwindow-17.9 {MoveSash, move right respects minsize, exludes pad} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
foreach w {.f1 .f2 .f3} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] \
- -sticky nsew -minsize 10 -padx 5
+ .p add [frame $w -height 20 -width 20 -bg $c] \
+ -sticky nsew -minsize 10 -padx 5
}
.p sash place 0 100 0
# Get the new sash coord; it should have moved as far as possible,
# respecting minsizes.
- set result [.p sash coord 0]
-
- # Cleanup
- destroy .p .f1 .f2 .f3
-
- set result
-} [list 50 0]
-test panedwindow-18.10 {MoveSash, move right, negative minsize becomes 0} {
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 50 0]
+test panedwindow-17.10 {MoveSash, move right, negative minsize becomes 0} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
foreach w {.f1 .f2 .f3} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] \
- -sticky nsew -minsize -50
+ .p add [frame $w -height 20 -width 20 -bg $c] \
+ -sticky nsew -minsize -50
}
.p sash place 0 50 0
# Get the new sash coord; it should have moved as far as possible,
# respecting minsizes.
- set result [list [.p sash coord 0] [.p sash coord 1]]
-
- # Cleanup
- destroy .p .f1 .f2 .f3
-
- set result
-} [list [list 50 0] [list 52 0]]
-test panedwindow-18.11 {MoveSash, move left} {
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result [list [list 50 0] [list 52 0]]
+test panedwindow-17.11 {MoveSash, move left} -setup {
+ deleteWindows
+} -body {
set result {}
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
foreach w {.f1 .f2} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
}
# Get the requested width of the paned window
@@ -1054,139 +1674,132 @@ test panedwindow-18.11 {MoveSash, move left} {
# Check that the sash moved
lappend result [.p sash coord 0]
-
- # Cleanup
- destroy .p .f1 .f2
-
- set result
-} [list 42 42 {10 0}]
-test panedwindow-18.12 {MoveSash, move left, can't move outside of window} {
+} -cleanup {
+ deleteWindows
+} -result [list 42 42 {10 0}]
+test panedwindow-17.12 {MoveSash, move left, can't move outside of window} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
foreach w {.f1 .f2} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
}
.p sash place 0 -100 0
# Get the new sash coord; it should be clipped by the reqwidth of
# the panedwindow.
- set result [.p sash coord 0]
-
- # Cleanup
- destroy .p .f1 .f2
-
- set result
-} [list 0 0]
-test panedwindow-18.13 {MoveSash, move left respects minsize} {
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 0]
+test panedwindow-17.13 {MoveSash, move left respects minsize} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
foreach w {.f1 .f2} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
}
.p sash place 0 0 0
# Get the new sash coord; it should have moved as far as possible while
# respecting minsizes.
- set result [.p sash coord 0]
-
- # Cleanup
- destroy .p .f1 .f2
-
- set result
-} [list 10 0]
-test panedwindow-18.14 {MoveSash, move left respects minsize} {
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 10 0]
+test panedwindow-17.14 {MoveSash, move left respects minsize} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
foreach w {.f1 .f2 .f3} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
}
.p sash place 1 0 0
# Get the new sash coord; it should have moved as far as possible.
- set result [.p sash coord 1]
-
- # Cleanup
- destroy .p .f1 .f2 .f3
-
- set result
-} [list 22 0]
-test panedwindow-18.15 {MoveSash, move left pushes other sashes} {
+ .p sash coord 1
+} -cleanup {
+ deleteWindows
+} -result [list 22 0]
+test panedwindow-17.15 {MoveSash, move left pushes other sashes} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
foreach w {.f1 .f2 .f3} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
}
.p sash place 1 0 0
# Get the new sash coord; it should have moved as far as possible while
# respecting minsizes.
- set result [.p sash coord 0]
-
- # Cleanup
- destroy .p .f1 .f2 .f3
-
- set result
-} [list 0 0]
-test panedwindow-18.16 {MoveSash, move left pushes other sashes, respects minsize} {
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 0]
+test panedwindow-17.16 {MoveSash, move left pushes other sashes, respects minsize} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
foreach w {.f1 .f2 .f3} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
}
.p sash place 1 0 0
# Get the new sash coord; it should have moved as far as possible while
# respecting minsizes.
- set result [.p sash coord 0]
-
- # Cleanup
- destroy .p .f1 .f2 .f3
-
- set result
-} [list 10 0]
-test panedwindow-18.17 {MoveSash, move left respects minsize, exludes pad} {
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 10 0]
+test panedwindow-17.17 {MoveSash, move left respects minsize, exludes pad} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
foreach w {.f1 .f2 .f3} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] \
- -sticky nsew -minsize 10 -padx 5
+ .p add [frame $w -height 20 -width 20 -bg $c] \
+ -sticky nsew -minsize 10 -padx 5
}
.p sash place 1 0 0
# Get the new sash coord; it should have moved as far as possible,
# respecting minsizes.
- set result [.p sash coord 1]
-
- # Cleanup
- destroy .p .f1 .f2 .f3
-
- set result
-} [list 42 0]
-test panedwindow-18.18 {MoveSash, move left, negative minsize becomes 0} {
+ .p sash coord 1
+} -cleanup {
+ deleteWindows
+} -result [list 42 0]
+test panedwindow-17.18 {MoveSash, move left, negative minsize becomes 0} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
foreach w {.f1 .f2 .f3} c {red blue green} {
- .p add [frame $w -height 20 -width 20 -bg $c] \
- -sticky nsew -minsize -50
+ .p add [frame $w -height 20 -width 20 -bg $c] \
+ -sticky nsew -minsize -50
}
.p sash place 1 10 0
# Get the new sash coord; it should have moved as far as possible,
# respecting minsizes.
- set result [list [.p sash coord 0] [.p sash coord 1]]
-
- # Cleanup
- destroy .p .f1 .f2 .f3
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result [list [list 8 0] [list 10 0]]
- set result
-} [list [list 8 0] [list 10 0]]
-test panedwindow-19.1 {MoveSash, move down} {
+test panedwindow-18.1 {MoveSash, move down} -setup {
+ deleteWindows
+} -body {
set result {}
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
-orient vertical
foreach w {.f1 .f2} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
}
# Get the requested width of the paned window
@@ -1199,35 +1812,33 @@ test panedwindow-19.1 {MoveSash, move down} {
# Check that the sash moved
lappend result [.p sash coord 0]
-
- # Cleanup
- destroy .p .f1 .f2
-
- set result
-} [list 42 42 {0 30}]
-test panedwindow-19.2 {MoveSash, move down (unmapped) clipped by reqheight} {
+} -cleanup {
+ deleteWindows
+} -result [list 42 42 {0 30}]
+test panedwindow-18.2 {MoveSash, move down (unmapped) clipped by reqheight} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
-orient vertical
foreach w {.f1 .f2} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
}
.p sash place 0 0 100
# Get the new sash coord; it should be clipped by the reqheight of
# the panedwindow.
- set result [.p sash coord 0]
-
- # Cleanup
- destroy .p .f1 .f2
-
- set result
-} [list 0 40]
-test panedwindow-19.3 {MoveSash, move down (mapped, height < reqheight) clipped by height} {
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 40]
+test panedwindow-18.3 {MoveSash, move down (mapped, height < reqheight) clipped by height} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
-orient vertical
foreach w {.f1 .f2} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
}
# Put the panedwindow up on the display and give it a height < reqheight
@@ -1238,18 +1849,17 @@ test panedwindow-19.3 {MoveSash, move down (mapped, height < reqheight) clipped
# Get the new sash coord; it should be clipped by the visible height of
# the panedwindow.
- set result [.p sash coord 0]
-
- # Cleanup
- destroy .p .f1 .f2
-
- set result
-} [list 0 30]
-test panedwindow-19.4 {MoveSash, move down (mapped, height > reqheight) clipped by height} {
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 30]
+test panedwindow-18.4 {MoveSash, move down (mapped, height > reqheight) clipped by height} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
-orient vertical
foreach w {.f1 .f2} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
}
# Put the panedwindow up on the display and give it a width > reqwidth
@@ -1260,129 +1870,122 @@ test panedwindow-19.4 {MoveSash, move down (mapped, height > reqheight) clipped
# Get the new sash coord; it should be clipped by the visible width of
# the panedwindow.
- set result [.p sash coord 0]
-
- # Cleanup
- destroy .p .f1 .f2
-
- set result
-} [list 0 100]
-test panedwindow-19.5 {MoveSash, move down respects minsize} {
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 100]
+test panedwindow-18.5 {MoveSash, move down respects minsize} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
-orient vertical
foreach w {.f1 .f2} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
}
.p sash place 0 0 100
# Get the new sash coord; it should have moved as far as possible while
# respecting minsizes.
- set result [.p sash coord 0]
-
- # Cleanup
- destroy .p .f1 .f2
-
- set result
-} [list 0 30]
-test panedwindow-19.6 {MoveSash, move down respects minsize} {
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 30]
+test panedwindow-18.6 {MoveSash, move down respects minsize} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
-orient vertical
foreach w {.f1 .f2 .f3} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
}
.p sash place 0 0 100
# Get the new sash coord; it should have moved as far as possible while
# respecting minsizes.
- set result [.p sash coord 0]
-
- # Cleanup
- destroy .p .f1 .f2 .f3
-
- set result
-} [list 0 40]
-test panedwindow-19.7 {MoveSash, move down pushes other sashes} {
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 40]
+test panedwindow-18.7 {MoveSash, move down pushes other sashes} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
-orient vertical
foreach w {.f1 .f2 .f3} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
}
.p sash place 0 0 100
# Get the new sash coord; it should have moved as far as possible while
# respecting minsizes.
- set result [.p sash coord 1]
-
- # Cleanup
- destroy .p .f1 .f2 .f3
-
- set result
-} [list 0 62]
-test panedwindow-19.8 {MoveSash, move down pushes other sashes, respects minsize} {
+ .p sash coord 1
+} -cleanup {
+ deleteWindows
+} -result [list 0 62]
+test panedwindow-18.8 {MoveSash, move down pushes other sashes, respects minsize} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
-orient vertical
foreach w {.f1 .f2 .f3} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
}
.p sash place 0 0 100
# Get the new sash coord; it should have moved as far as possible while
# respecting minsizes.
- set result [.p sash coord 1]
-
- # Cleanup
- destroy .p .f1 .f2 .f3
-
- set result
-} [list 0 52]
-test panedwindow-19.9 {MoveSash, move down respects minsize, exludes pad} {
+ .p sash coord 1
+} -cleanup {
+ deleteWindows
+} -result [list 0 52]
+test panedwindow-18.9 {MoveSash, move down respects minsize, exludes pad} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
-orient vertical
foreach w {.f1 .f2 .f3} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] \
- -sticky nsew -minsize 10 -pady 5
+ .p add [frame $w -height 20 -width 20 -bg $c] \
+ -sticky nsew -minsize 10 -pady 5
}
.p sash place 0 0 100
# Get the new sash coord; it should have moved as far as possible,
# respecting minsizes.
- set result [.p sash coord 0]
-
- # Cleanup
- destroy .p .f1 .f2 .f3
-
- set result
-} [list 0 50]
-test panedwindow-19.10 {MoveSash, move right, negative minsize becomes 0} {
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 50]
+test panedwindow-18.10 {MoveSash, move right, negative minsize becomes 0} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
-orient vertical
foreach w {.f1 .f2 .f3} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] \
- -sticky nsew -minsize -50
+ .p add [frame $w -height 20 -width 20 -bg $c] \
+ -sticky nsew -minsize -50
}
.p sash place 0 0 50
# Get the new sash coord; it should have moved as far as possible,
# respecting minsizes.
- set result [list [.p sash coord 0] [.p sash coord 1]]
-
- # Cleanup
- destroy .p .f1 .f2 .f3
-
- set result
-} [list [list 0 50] [list 0 52]]
-test panedwindow-19.11 {MoveSash, move up} {
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result [list [list 0 50] [list 0 52]]
+test panedwindow-18.11 {MoveSash, move up} -setup {
+ deleteWindows
+} -body {
set result {}
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
-orient vertical
foreach w {.f1 .f2} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
}
# Get the requested width of the paned window
@@ -1395,178 +1998,180 @@ test panedwindow-19.11 {MoveSash, move up} {
# Check that the sash moved
lappend result [.p sash coord 0]
-
- # Cleanup
- destroy .p .f1 .f2
-
- set result
-} [list 42 42 {0 10}]
-test panedwindow-19.12 {MoveSash, move up, can't move outside of window} {
+} -cleanup {
+ deleteWindows
+} -result [list 42 42 {0 10}]
+test panedwindow-18.12 {MoveSash, move up, can't move outside of window} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
-orient vertical
foreach w {.f1 .f2} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
}
.p sash place 0 0 -100
# Get the new sash coord; it should be clipped by the reqwidth of
# the panedwindow.
- set result [.p sash coord 0]
-
- # Cleanup
- destroy .p .f1 .f2
-
- set result
-} [list 0 0]
-test panedwindow-19.13 {MoveSash, move up respects minsize} {
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 0]
+test panedwindow-18.13 {MoveSash, move up respects minsize} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
-orient vertical
foreach w {.f1 .f2} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
}
.p sash place 0 0 0
# Get the new sash coord; it should have moved as far as possible while
# respecting minsizes.
- set result [.p sash coord 0]
-
- # Cleanup
- destroy .p .f1 .f2
-
- set result
-} [list 0 10]
-test panedwindow-19.14 {MoveSash, move up respects minsize} {
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 10]
+test panedwindow-18.14 {MoveSash, move up respects minsize} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
-orient vertical
foreach w {.f1 .f2 .f3} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
}
.p sash place 1 0 0
# Get the new sash coord; it should have moved as far as possible.
- set result [.p sash coord 1]
-
- # Cleanup
- destroy .p .f1 .f2 .f3
-
- set result
-} [list 0 22]
-test panedwindow-19.15 {MoveSash, move up pushes other sashes} {
+ .p sash coord 1
+} -cleanup {
+ deleteWindows
+} -result [list 0 22]
+test panedwindow-18.15 {MoveSash, move up pushes other sashes} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
-orient vertical
foreach w {.f1 .f2 .f3} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew
}
.p sash place 1 0 0
# Get the new sash coord; it should have moved as far as possible while
# respecting minsizes.
- set result [.p sash coord 0]
-
- # Cleanup
- destroy .p .f1 .f2 .f3
-
- set result
-} [list 0 0]
-test panedwindow-19.16 {MoveSash, move up pushes other sashes, respects minsize} {
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 0]
+test panedwindow-18.16 {MoveSash, move up pushes other sashes, respects minsize} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
-orient vertical
foreach w {.f1 .f2 .f3} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
+ .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10
}
.p sash place 1 0 0
# Get the new sash coord; it should have moved as far as possible while
# respecting minsizes.
- set result [.p sash coord 0]
-
- # Cleanup
- destroy .p .f1 .f2 .f3
-
- set result
-} [list 0 10]
-test panedwindow-19.17 {MoveSash, move up respects minsize, exludes pad} {
+ .p sash coord 0
+} -cleanup {
+ deleteWindows
+} -result [list 0 10]
+test panedwindow-18.17 {MoveSash, move up respects minsize, exludes pad} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
-orient vertical
foreach w {.f1 .f2 .f3} c {red blue} {
- .p add [frame $w -height 20 -width 20 -bg $c] \
- -sticky nsew -minsize 10 -pady 5
+ .p add [frame $w -height 20 -width 20 -bg $c] \
+ -sticky nsew -minsize 10 -pady 5
}
.p sash place 1 0 0
# Get the new sash coord; it should have moved as far as possible,
# respecting minsizes.
- set result [.p sash coord 1]
-
- # Cleanup
- destroy .p .f1 .f2 .f3
-
- set result
-} [list 0 42]
-test panedwindow-19.18 {MoveSash, move up, negative minsize becomes 0} {
+ .p sash coord 1
+} -cleanup {
+ deleteWindows
+} -result [list 0 42]
+test panedwindow-18.18 {MoveSash, move up, negative minsize becomes 0} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
-orient vertical
foreach w {.f1 .f2 .f3} c {red blue green} {
- .p add [frame $w -height 20 -width 20 -bg $c] \
- -sticky nsew -minsize -50
+ .p add [frame $w -height 20 -width 20 -bg $c] \
+ -sticky nsew -minsize -50
}
.p sash place 1 0 10
# Get the new sash coord; it should have moved as far as possible,
# respecting minsizes.
- set result [list [.p sash coord 0] [.p sash coord 1]]
-
- # Cleanup
- destroy .p .f1 .f2 .f3
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result [list [list 0 8] [list 0 10]]
- set result
-} [list [list 0 8] [list 0 10]]
# The following tests check that the panedwindow is correctly computing its
# geometry based on the various configuration options that can affect the
# geometry.
-test panedwindow-20.1 {ComputeGeometry, reqheight taken from widgets} {
+test panedwindow-19.1 {ComputeGeometry, reqheight taken from widgets} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
foreach w {.f1 .f2 .f3} {
- .p add [frame $w -width 20 -height 20 -bg blue]
+ .p add [frame $w -width 20 -height 20 -bg blue]
}
set result [list [list [winfo reqwidth .p] [winfo reqheight .p]]]
.f3 configure -height 40
lappend result [list [winfo reqwidth .p] [winfo reqheight .p]]
- destroy .p .f1 .f2 .f3
- set result
-} [list [list 60 20] [list 60 40]]
-test panedwindow-20.2 {ComputeGeometry, reqheight taken from widgets} {
+} -cleanup {
+ deleteWindows
+} -result [list [list 60 20] [list 60 40]]
+
+test panedwindow-19.2 {ComputeGeometry, reqheight taken from widgets} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
foreach w {.f1 .f2 .f3} {
- .p add [frame $w -width 20 -height 20 -bg blue]
+ .p add [frame $w -width 20 -height 20 -bg blue]
}
set result [list [list [winfo reqwidth .p] [winfo reqheight .p]]]
.p paneconfigure .f3 -height 40
lappend result [list [winfo reqwidth .p] [winfo reqheight .p]]
- destroy .p .f1 .f2 .f3
- set result
-} [list [list 60 20] [list 60 40]]
-test panedwindow-20.3 {ComputeGeometry, reqheight taken from widgets} {
+} -cleanup {
+ deleteWindows
+} -result [list [list 60 20] [list 60 40]]
+
+test panedwindow-19.3 {ComputeGeometry, reqheight taken from widgets} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0
foreach w {.f1 .f2 .f3} {
- .p add [frame $w -width 20 -height 20 -bg blue] -pady 20
+ .p add [frame $w -width 20 -height 20 -bg blue] -pady 20
}
set result [list [list [winfo reqwidth .p] [winfo reqheight .p]]]
.p paneconfigure .f3 -height 40
lappend result [list [winfo reqwidth .p] [winfo reqheight .p]]
- destroy .p .f1 .f2 .f3
- set result
-} [list [list 60 60] [list 60 80]]
-test panedwindow-20.4 {ComputeGeometry, reqwidth taken from widgets} {
+} -cleanup {
+ deleteWindows
+} -result [list [list 60 60] [list 60 80]]
+
+test panedwindow-19.4 {ComputeGeometry, reqwidth taken from widgets} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 \
-orient vertical
foreach w {.f1 .f2 .f3} {
@@ -1575,10 +2180,13 @@ test panedwindow-20.4 {ComputeGeometry, reqwidth taken from widgets} {
set result [list [list [winfo reqwidth .p] [winfo reqheight .p]]]
.f3 configure -width 40
lappend result [list [winfo reqwidth .p] [winfo reqheight .p]]
- destroy .p .f1 .f2 .f3
- set result
-} [list [list 20 60] [list 40 60]]
-test panedwindow-20.5 {ComputeGeometry, reqwidth taken from widgets} {
+} -cleanup {
+ deleteWindows
+} -result [list [list 20 60] [list 40 60]]
+
+test panedwindow-19.5 {ComputeGeometry, reqwidth taken from widgets} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 \
-orient vertical
foreach w {.f1 .f2 .f3} {
@@ -1587,10 +2195,13 @@ test panedwindow-20.5 {ComputeGeometry, reqwidth taken from widgets} {
set result [list [list [winfo reqwidth .p] [winfo reqheight .p]]]
.p paneconfigure .f3 -width 40
lappend result [list [winfo reqwidth .p] [winfo reqheight .p]]
- destroy .p .f1 .f2 .f3
- set result
-} [list [list 20 60] [list 40 60]]
-test panedwindow-20.6 {ComputeGeometry, reqwidth taken from widgets} {
+} -cleanup {
+ deleteWindows
+} -result [list [list 20 60] [list 40 60]]
+
+test panedwindow-19.6 {ComputeGeometry, reqwidth taken from widgets} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 \
-orient vertical
foreach w {.f1 .f2 .f3} {
@@ -1599,219 +2210,2153 @@ test panedwindow-20.6 {ComputeGeometry, reqwidth taken from widgets} {
set result [list [list [winfo reqwidth .p] [winfo reqheight .p]]]
.p paneconfigure .f3 -width 40
lappend result [list [winfo reqwidth .p] [winfo reqheight .p]]
- destroy .p .f1 .f2 .f3
- set result
-} [list [list 60 60] [list 80 60]]
-
-set i 6
-foreach bd {0 2} {
- foreach sp {0 5} {
- foreach sw {0 3} {
- foreach h {0 1} {
- test panedwindow-20.[incr i]-$bd-$sp-$sw-$h \
- {ComputeGeometry, one slave, reqsize set properly} {
- # With just one slave, sashpad and sashwidth should not
- # affect the panedwindow's geometry, since no sash should
- # ever be drawn.
- panedwindow .p -borderwidth $bd -sashpad $sp \
- -sashwidth $sw -handlesize 6 -showhandle $h
- .p add [frame .p.f -width 20 -height 20 -bg red] -padx $h \
+} -cleanup {
+ deleteWindows
+} -result [list [list 60 60] [list 80 60]]
+
+test panedwindow-19.7 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 20}
+
+test panedwindow-19.8 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {60 20}
+
+test panedwindow-19.9 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{20 0} {40 0}}
+
+test panedwindow-19.10 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{11 3 20 20} {53 3 20 20} {95 3 20 20}}
+
+test panedwindow-19.11 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -orient vertical -sashwidth 0 -handlesize 6 \
+ -showhandle 0
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 20}
+
+test panedwindow-19.12 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
-sticky ""
- set result [list [winfo reqwidth .p] [winfo reqheight .p]]
- destroy .p .p.f
- set result
- } [list [expr {(2 * $bd) + 20 + (2 * $h)}] \
- [expr {(2 * $bd) + 20}]]
-
- test panedwindow-20.[incr i]-$bd-$sp-$sw-$h \
- {ComputeGeometry, three panes, reqsize set properly} {
- panedwindow .p -borderwidth $bd -sashpad $sp \
- -sashwidth $sw -handlesize 6 -showhandle $h
- foreach w {.p.f1 .p.f2 .p.f3} {
- .p add [frame $w -width 20 -height 20 -bg blue] \
- -sticky ""
- }
- set result [list [winfo reqwidth .p] [winfo reqheight .p]]
- destroy .p .p.f1 .p.f2 .p.f3
- set result
- } [list [expr {(2 * $bd) + ($h?12:(2*$sw)) + (4*$sp) + 60}] \
- [expr {(2 * $bd) + 20}]]
-
- test panedwindow-20.[incr i]-$bd-$sp-$sw-$h \
- {ComputeGeometry, sash coords} {
- panedwindow .p -borderwidth $bd -sashpad $sp \
- -sashwidth $sw -handlesize 6 -showhandle $h
- foreach w {.f1 .f2 .f3} {
- .p add [frame $w -width 20 -height 20 -bg blue] \
- -sticky ""
- }
- set result [list [.p sash coord 0] [.p sash coord 1]]
- destroy .p .f1 .f2 .f3
- set result
- } [list [list [expr {$bd+20+($h?(6-$sw)/2:0)+$sp}] $bd] \
- [list [expr {$bd+40+($h?6+(6-$sw)/2:$sw)+(3*$sp)}] \
- $bd]]
-
- test panedwindow-20.[incr i]-$bd-$sp-$sw-$h \
- {ComputeGeometry/ArrangePanes, slave coords} {
- panedwindow .p -borderwidth $bd -sashpad $sp \
- -sashwidth $sw -handlesize 6 -showhandle $h
- foreach w {.p.f1 .p.f2 .p.f3} {
- .p add [frame $w -width 20 -height 20 -bg blue] \
- -sticky nsew -pady 3 -padx 11
- }
- pack .p
- update
- set result {}
- foreach w {.p.f1 .p.f2 .p.f3} {
- lappend result [list [winfo x $w] [winfo y $w] \
- [winfo width $w] [winfo height $w]]
- }
- destroy .p .p.f1 .p.f2 .p.f3
- set result
- } [list [list [expr {$bd+11}] [expr {$bd+3}] 20 20] \
- [list [expr {$bd+53+($h?6:$sw)+(2*$sp)}] \
- [expr {$bd+3}] 20 20] \
- [list [expr {$bd+95+($h?12:2*$sw)+(4*$sp)}] \
- [expr {$bd+3}] 20 20]]
-
- test panedwindow-20.[incr i]-$bd-$sp-$sw-$h \
- {ComputeGeometry, one slave, vertical} {
- # With just one slave, sashpad and sashwidth should not
- # affect the panedwindow's geometry, since no sash should
- # ever be drawn.
- panedwindow .p -borderwidth $bd -sashpad $sp \
- -orient vertical -sashwidth $sw -handlesize 6 \
- -showhandle $h
- .p add [frame .f -width 20 -height 20 -bg red] -pady $h \
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 60}
+
+test panedwindow-19.13 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
-sticky ""
- set result [list [winfo reqwidth .p] [winfo reqheight .p]]
- destroy .p .f
- set result
- } [list [expr {(2 * $bd) + 20}] \
- [expr {(2 * $bd) + 20 + (2 * $h)}]]
-
- test panedwindow-20.[incr i]-$bd-$sp-$sw-$h \
- {ComputeGeometry, three panes, vertical} {
- panedwindow .p -borderwidth $bd -sashpad $sp \
- -sashwidth $sw -handlesize 6 -showhandle $h \
- -orient vertical
- foreach w {.f1 .f2 .f3} {
- .p add [frame $w -width 20 -height 20 -bg blue] \
- -sticky ""
- }
- set result [list [winfo reqwidth .p] [winfo reqheight .p]]
- destroy .p .f1 .f2 .f3
- set result
- } [list [expr {(2 * $bd) + 20}] \
- [expr {(2 * $bd) + ($h?12:(2*$sw)) + (4*$sp) + 60}]]
-
- test panedwindow-20.[incr i]-$bd-$sp-$sw-$h \
- {ComputeGeometry, sash coords, vertical} {
- panedwindow .p -borderwidth $bd -sashpad $sp \
- -sashwidth $sw -handlesize 6 -showhandle $h \
- -orient vertical
- foreach w {.f1 .f2 .f3} {
- .p add [frame $w -width 20 -height 20 -bg blue] \
- -sticky ""
- }
- set result [list [.p sash coord 0] [.p sash coord 1]]
- destroy .p .f1 .f2 .f3
- set result
- } [list [list $bd [expr {$bd+20+($h?(6-$sw)/2:0)+$sp}]] \
- [list $bd \
- [expr {$bd+40+($h?6+(6-$sw)/2:$sw)+(3*$sp)}]]]
-
- test panedwindow-20.[incr i]-$bd-$sp-$sw-$h \
- {ComputeGeometry/ArrangePanes, slave coords, vert} {
- panedwindow .p -borderwidth $bd -sashpad $sp \
- -sashwidth $sw -handlesize 6 -showhandle $h \
- -orient vertical
- foreach w {.p.f1 .p.f2 .p.f3} {
- .p add [frame $w -width 20 -height 20 -bg blue] \
- -sticky nsew -pady 11 -padx 3
- }
- pack .p
- update
- set result {}
- foreach w {.p.f1 .p.f2 .p.f3} {
- lappend result [list [winfo x $w] [winfo y $w] \
- [winfo width $w] [winfo height $w]]
- }
- destroy .p .p.f1 .p.f2 .p.f3
- set result
- } [list [list [expr {$bd+3}] [expr {$bd+11}] 20 20] \
- [list [expr {$bd+3}] \
- [expr {$bd+53+($h?6:$sw)+(2*$sp)}] 20 20] \
- [list [expr {$bd+3}] \
- [expr {$bd+95+($h?12:2*$sw)+(4*$sp)}] 20 20]]
- }
- }
- }
-}
-
-test panedwindow-21.1 {destroyed widgets are removed from panedwindow} {
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{0 20} {0 40}}
+
+test panedwindow-19.14 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{3 11 20 20} {3 53 20 20} {3 95 20 20}}
+test panedwindow-19.15 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {22 20}
+
+test panedwindow-19.16 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {72 20}
+
+test panedwindow-19.17 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{23 0} {49 0}}
+
+test panedwindow-19.18 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{11 3 20 20} {59 3 20 20} {107 3 20 20}}
+
+test panedwindow-19.19 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -orient vertical -sashwidth 0 -handlesize 6 \
+ -showhandle 1
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 22}
+
+test panedwindow-19.20 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 72}
+
+test panedwindow-19.21 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{0 23} {0 49}}
+
+test panedwindow-19.22 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{3 11 20 20} {3 59 20 20} {3 107 20 20}}
+test panedwindow-19.23 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 20}
+
+test panedwindow-19.24 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {66 20}
+
+test panedwindow-19.25 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{20 0} {43 0}}
+
+test panedwindow-19.26 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{11 3 20 20} {56 3 20 20} {101 3 20 20}}
+
+test panedwindow-19.27 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -orient vertical -sashwidth 3 -handlesize 6 \
+ -showhandle 0
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 20}
+
+test panedwindow-19.28 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 66}
+
+test panedwindow-19.29 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{0 20} {0 43}}
+
+test panedwindow-19.30 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{3 11 20 20} {3 56 20 20} {3 101 20 20}}
+test panedwindow-19.31 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {22 20}
+
+test panedwindow-19.32 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {72 20}
+
+test panedwindow-19.33 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{21 0} {47 0}}
+
+test panedwindow-19.34 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{11 3 20 20} {59 3 20 20} {107 3 20 20}}
+
+test panedwindow-19.35 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -orient vertical -sashwidth 3 -handlesize 6 \
+ -showhandle 1
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 22}
+
+test panedwindow-19.36 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 72}
+
+test panedwindow-19.37 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{0 21} {0 47}}
+
+test panedwindow-19.38 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{3 11 20 20} {3 59 20 20} {3 107 20 20}}
+test panedwindow-19.39 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 20}
+
+test panedwindow-19.40 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {80 20}
+
+test panedwindow-19.41 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{25 0} {55 0}}
+
+test panedwindow-19.42 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{11 3 20 20} {63 3 20 20} {115 3 20 20}}
+
+test panedwindow-19.43 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -orient vertical -sashwidth 0 -handlesize 6 \
+ -showhandle 0
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 20}
+
+test panedwindow-19.44 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 80}
+
+test panedwindow-19.45 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{0 25} {0 55}}
+
+test panedwindow-19.46 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{3 11 20 20} {3 63 20 20} {3 115 20 20}}
+test panedwindow-19.47 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {22 20}
+
+test panedwindow-19.48 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {92 20}
+
+test panedwindow-19.49 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{28 0} {64 0}}
+
+test panedwindow-19.50 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{11 3 20 20} {69 3 20 20} {127 3 20 20}}
+
+test panedwindow-19.51 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -orient vertical -sashwidth 0 -handlesize 6 \
+ -showhandle 1
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 22}
+
+test panedwindow-19.52 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 92}
+
+test panedwindow-19.53 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{0 28} {0 64}}
+
+test panedwindow-19.54 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{3 11 20 20} {3 69 20 20} {3 127 20 20}}
+test panedwindow-19.55 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 20}
+
+test panedwindow-19.56 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {86 20}
+
+test panedwindow-19.57 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{25 0} {58 0}}
+
+test panedwindow-19.58 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{11 3 20 20} {66 3 20 20} {121 3 20 20}}
+
+test panedwindow-19.59 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -orient vertical -sashwidth 3 -handlesize 6 \
+ -showhandle 0
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 20}
+
+test panedwindow-19.60 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 86}
+
+test panedwindow-19.61 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{0 25} {0 58}}
+
+test panedwindow-19.62 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{3 11 20 20} {3 66 20 20} {3 121 20 20}}
+test panedwindow-19.63 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {22 20}
+
+test panedwindow-19.64 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {92 20}
+
+test panedwindow-19.65 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{26 0} {62 0}}
+
+test panedwindow-19.66 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{11 3 20 20} {69 3 20 20} {127 3 20 20}}
+
+test panedwindow-19.67 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -orient vertical -sashwidth 3 -handlesize 6 \
+ -showhandle 1
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 22}
+
+test panedwindow-19.68 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {20 92}
+
+test panedwindow-19.69 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{0 26} {0 62}}
+
+test panedwindow-19.70 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 0 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{3 11 20 20} {3 69 20 20} {3 127 20 20}}
+test panedwindow-19.71 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 24}
+
+test panedwindow-19.72 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {64 24}
+
+test panedwindow-19.73 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{22 2} {42 2}}
+
+test panedwindow-19.74 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{13 5 20 20} {55 5 20 20} {97 5 20 20}}
+
+test panedwindow-19.75 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -orient vertical -sashwidth 0 -handlesize 6 \
+ -showhandle 0
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 24}
+
+test panedwindow-19.76 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 64}
+
+test panedwindow-19.77 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{2 22} {2 42}}
+
+test panedwindow-19.78 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{5 13 20 20} {5 55 20 20} {5 97 20 20}}
+test panedwindow-19.79 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {26 24}
+
+test panedwindow-19.80 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {76 24}
+
+test panedwindow-19.81 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{25 2} {51 2}}
+
+test panedwindow-19.82 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{13 5 20 20} {61 5 20 20} {109 5 20 20}}
+
+test panedwindow-19.83 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -orient vertical -sashwidth 0 -handlesize 6 \
+ -showhandle 1
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 26}
+
+test panedwindow-19.84 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 76}
+
+test panedwindow-19.85 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{2 25} {2 51}}
+
+test panedwindow-19.86 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 0 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{5 13 20 20} {5 61 20 20} {5 109 20 20}}
+test panedwindow-19.87 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 24}
+
+test panedwindow-19.88 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {70 24}
+
+test panedwindow-19.89 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{22 2} {45 2}}
+
+test panedwindow-19.90 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{13 5 20 20} {58 5 20 20} {103 5 20 20}}
+
+test panedwindow-19.91 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -orient vertical -sashwidth 3 -handlesize 6 \
+ -showhandle 0
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 24}
+
+test panedwindow-19.92 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 70}
+
+test panedwindow-19.93 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{2 22} {2 45}}
+
+test panedwindow-19.94 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{5 13 20 20} {5 58 20 20} {5 103 20 20}}
+test panedwindow-19.95 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {26 24}
+
+test panedwindow-19.96 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {76 24}
+
+test panedwindow-19.97 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{23 2} {49 2}}
+
+test panedwindow-19.98 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{13 5 20 20} {61 5 20 20} {109 5 20 20}}
+
+test panedwindow-19.99 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -orient vertical -sashwidth 3 -handlesize 6 \
+ -showhandle 1
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 26}
+
+test panedwindow-19.100 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 76}
+
+test panedwindow-19.101 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{2 23} {2 49}}
+
+test panedwindow-19.102 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 0 \
+ -sashwidth 3 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{5 13 20 20} {5 61 20 20} {5 109 20 20}}
+test panedwindow-19.103 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 24}
+
+test panedwindow-19.104 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {84 24}
+
+test panedwindow-19.105 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{27 2} {57 2}}
+
+test panedwindow-19.106 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{13 5 20 20} {65 5 20 20} {117 5 20 20}}
+
+test panedwindow-19.107 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -orient vertical -sashwidth 0 -handlesize 6 \
+ -showhandle 0
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 24}
+
+test panedwindow-19.108 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 84}
+
+test panedwindow-19.109 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{2 27} {2 57}}
+
+test panedwindow-19.110 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{5 13 20 20} {5 65 20 20} {5 117 20 20}}
+test panedwindow-19.111 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {26 24}
+
+test panedwindow-19.112 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {96 24}
+
+test panedwindow-19.113 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{30 2} {66 2}}
+
+test panedwindow-19.114 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{13 5 20 20} {71 5 20 20} {129 5 20 20}}
+
+test panedwindow-19.115 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -orient vertical -sashwidth 0 -handlesize 6 \
+ -showhandle 1
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 26}
+
+test panedwindow-19.116 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 96}
+
+test panedwindow-19.117 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{2 30} {2 66}}
+
+test panedwindow-19.118 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 0 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{5 13 20 20} {5 71 20 20} {5 129 20 20}}
+test panedwindow-19.119 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 24}
+
+test panedwindow-19.120 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {90 24}
+
+test panedwindow-19.121 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{27 2} {60 2}}
+
+test panedwindow-19.122 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{13 5 20 20} {68 5 20 20} {123 5 20 20}}
+
+test panedwindow-19.123 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -orient vertical -sashwidth 3 -handlesize 6 \
+ -showhandle 0
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 24}
+
+test panedwindow-19.124 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 90}
+
+test panedwindow-19.125 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{2 27} {2 60}}
+
+test panedwindow-19.126 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 0 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{5 13 20 20} {5 68 20 20} {5 123 20 20}}
+test panedwindow-19.127 {ComputeGeometry, one slave, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {26 24}
+
+test panedwindow-19.128 {ComputeGeometry, three panes, reqsize set properly} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {96 24}
+
+test panedwindow-19.129 {ComputeGeometry, sash coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{28 2} {64 2}}
+
+test panedwindow-19.130 {ComputeGeometry/ArrangePanes, slave coords} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 3 -padx 11
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{13 5 20 20} {71 5 20 20} {129 5 20 20}}
+
+test panedwindow-19.131 {ComputeGeometry, one slave, vertical} -setup {
+ deleteWindows
+} -body {
+ # With just one slave, sashpad and sashwidth should not
+ # affect the panedwindow's geometry, since no sash should
+ # ever be drawn.
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -orient vertical -sashwidth 3 -handlesize 6 \
+ -showhandle 1
+ .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \
+ -sticky ""
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 26}
+
+test panedwindow-19.132 {ComputeGeometry, three panes, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [winfo reqwidth .p] [winfo reqheight .p]
+} -cleanup {
+ deleteWindows
+} -result {24 96}
+
+test panedwindow-19.133 {ComputeGeometry, sash coords, vertical} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.f1 .f2 .f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky ""
+ }
+ list [.p sash coord 0] [.p sash coord 1]
+} -cleanup {
+ deleteWindows
+} -result {{2 28} {2 64}}
+
+test panedwindow-19.134 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -borderwidth 2 -sashpad 5 \
+ -sashwidth 3 -handlesize 6 -showhandle 1 \
+ -orient vertical
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ .p add [frame $w -width 20 -height 20 -bg blue] \
+ -sticky nsew -pady 11 -padx 3
+ }
+ pack .p
+ update
+ set result {}
+ foreach w {.p.f1 .p.f2 .p.f3} {
+ lappend result [list [winfo x $w] [winfo y $w] \
+ [winfo width $w] [winfo height $w]]
+ }
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {{5 13 20 20} {5 71 20 20} {5 129 20 20}}
+
+
+test panedwindow-20.1 {destroyed widgets are removed from panedwindow} -setup {
+ deleteWindows
+} -body {
panedwindow .p
.p add [frame .f -width 20 -height 20 -bg blue]
destroy .f
- set result [.p panes]
- destroy .p
- set result
-} {}
-test panedwindow-21.2 {destroyed slave causes geometry recomputation} {
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {}
+test panedwindow-20.2 {destroyed slave causes geometry recomputation} -setup {
+ deleteWindows
+} -body {
panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 2
.p add [frame .f -width 20 -height 20 -bg blue] \
[frame .f2 -width 20 -height 20 -bg red]
destroy .f
- set result [winfo reqwidth .p]
- destroy .p .f2
- set result
-} 20
+ winfo reqwidth .p
+} -cleanup {
+ deleteWindows
+} -result 20
-test panedwindow-22.1 {ArrangePanes, extra space is given to the last pane} {
+
+test panedwindow-21.1 {ArrangePanes, extra space is given to the last pane} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
.p add [frame .f1 -width 20 -height 20 -bg blue] \
[frame .f2 -width 20 -height 20 -bg red] -sticky nsew
place .p -width 100 -x 0 -y 0
update
- set result [winfo width .f2]
- destroy .p .f1 .f2
- set result
-} 78
-test panedwindow-22.2 {ArrangePanes, extra space is given to the last pane} {
+ winfo width .f2
+} -cleanup {
+ deleteWindows
+} -result 78
+test panedwindow-21.2 {ArrangePanes, extra space is given to the last pane} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
-orient vertical
.p add [frame .f1 -width 20 -height 20 -bg blue] \
[frame .f2 -width 20 -height 20 -bg red] -sticky nsew
place .p -height 100 -x 0 -y 0
update
- set result [winfo height .f2]
- destroy .p .f1 .f2
- set result
-} 78
-test panedwindow-22.3 {ArrangePanes, explicit height/width are preferred} {
+ winfo height .f2
+} -cleanup {
+ deleteWindows
+} -result 78
+test panedwindow-21.3 {ArrangePanes, explicit height/width are preferred} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
.p add [frame .f1 -width 20 -height 20 -bg blue] \
[frame .f2 -width 20 -height 20 -bg red] -sticky ""
.p paneconfigure .f1 -width 10 -height 15
pack .p
update
- set result [list [winfo width .f1] [winfo height .f1]]
- destroy .p .f1 .f2
- set result
-} {10 15}
-test panedwindow-22.4 {ArrangePanes, panes clipped by size of pane} {
+ list [winfo width .f1] [winfo height .f1]
+} -cleanup {
+ deleteWindows
+} -result {10 15}
+test panedwindow-21.4 {ArrangePanes, panes clipped by size of pane} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
.p add [frame .f1 -width 20 -height 20 -bg blue] \
[frame .f2 -width 20 -height 20 -bg red]
.p sash place 0 10 0
pack .p
update
- set result [list [winfo width .f1] [winfo height .f1]]
- destroy .p .f1 .f2
- set result
-} {10 20}
-test panedwindow-22.5 {ArrangePanes, panes clipped by size of pane} {
+ list [winfo width .f1] [winfo height .f1]
+} -cleanup {
+ deleteWindows
+} -result {10 20}
+test panedwindow-21.5 {ArrangePanes, panes clipped by size of pane} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
-orient vertical
.p add [frame .f1 -width 20 -height 20 -bg blue] \
@@ -1819,32 +4364,38 @@ test panedwindow-22.5 {ArrangePanes, panes clipped by size of pane} {
.p sash place 0 0 10
pack .p
update
- set result [list [winfo width .f1] [winfo height .f1]]
- destroy .p .f1 .f2
- set result
-} {20 10}
-test panedwindow-22.6 {ArrangePanes, height of pane taken from total height} {
+ list [winfo width .f1] [winfo height .f1]
+} -cleanup {
+ deleteWindows
+} -result {20 10}
+test panedwindow-21.6 {ArrangePanes, height of pane taken from total height} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
.p add [frame .p.f1 -width 20 -height 20 -bg blue] \
[frame .p.f2 -width 20 -height 40 -bg red] -sticky ""
pack .p
update
- set result [list [winfo y .p.f1]]
- destroy .p .p.f1 .p.f2
- set result
-} 10
-test panedwindow-22.8 {ArrangePanes, width of pane taken from total width} {
+ winfo y .p.f1
+} -cleanup {
+ deleteWindows
+} -result 10
+test panedwindow-21.7 {ArrangePanes, width of pane taken from total width} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
-orient vertical
.p add [frame .p.f1 -width 20 -height 20 -bg blue] \
[frame .p.f2 -width 40 -height 40 -bg red] -sticky ""
pack .p
update
- set result [list [winfo x .p.f1]]
- destroy .p .p.f1 .p.f2
- set result
-} 10
-test panedwindow-22.9 {ArrangePanes, panes with width <= 0 are unmapped} {
+ winfo x .p.f1
+} -cleanup {
+ deleteWindows
+} -result 10
+test panedwindow-21.8 {ArrangePanes, panes with width <= 0 are unmapped} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
.p add [frame .f1 -width 20 -height 20 -bg blue] \
[frame .f2 -width 20 -height 40 -bg red]
@@ -1854,10 +4405,12 @@ test panedwindow-22.9 {ArrangePanes, panes with width <= 0 are unmapped} {
.p sash place 0 0 0
update
lappend result [winfo ismapped .f1]
- destroy .p .f1 .f2
- set result
-} {1 0}
-test panedwindow-22.10 {ArrangePanes, panes with width <= 0 are unmapped} {
+} -cleanup {
+ deleteWindows
+} -result {1 0}
+test panedwindow-21.9 {ArrangePanes, panes with width <= 0 are unmapped} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
.p add [frame .p.f1 -width 20 -height 20 -bg blue] \
[frame .p.f2 -width 20 -height 40 -bg red]
@@ -1867,10 +4420,12 @@ test panedwindow-22.10 {ArrangePanes, panes with width <= 0 are unmapped} {
.p sash place 0 0 0
update
lappend result [winfo ismapped .p.f1]
- destroy .p .p.f1 .p.f2
- set result
-} {1 0}
-test panedwindow-22.11 {ArrangePanes, panes with width <= 0 are unmapped} {
+} -cleanup {
+ deleteWindows
+} -result {1 0}
+test panedwindow-21.10 {ArrangePanes, panes with width <= 0 are unmapped} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 -orient vertical
.p add [frame .p.f1 -width 20 -height 20 -bg blue] \
[frame .p.f2 -width 20 -height 40 -bg red]
@@ -1880,32 +4435,37 @@ test panedwindow-22.11 {ArrangePanes, panes with width <= 0 are unmapped} {
.p sash place 0 0 0
update
lappend result [winfo ismapped .p.f1]
- destroy .p .p.f1 .p.f2
- set result
-} {1 0}
-test panedwindow-22.12 {ArrangePanes, last pane shrinks} {
+} -cleanup {
+ deleteWindows
+} -result {1 0}
+test panedwindow-21.11 {ArrangePanes, last pane shrinks} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2
.p add [frame .f1 -width 20 -height 20 -bg blue] \
[frame .f2 -width 20 -height 20 -bg red] -sticky nsew
place .p -width 40 -x 0 -y 0
update
- set result [winfo width .f2]
- destroy .p .f1 .f2
- set result
-} 18
-test panedwindow-22.13 {ArrangePanes, last pane shrinks} {
+ winfo width .f2
+} -cleanup {
+ deleteWindows
+} -result 18
+test panedwindow-21.12 {ArrangePanes, last pane shrinks} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \
-orient vertical
.p add [frame .f1 -width 20 -height 20 -bg blue] \
[frame .f2 -width 20 -height 20 -bg red] -sticky nsew
place .p -height 40 -x 0 -y 0
update
- set result [winfo height .f2]
- destroy .p .f1 .f2
- set result
-} 18
-test panedwindow-22.14 {ArrangePanes, panedwindow resizes} {
- -body {
+ winfo height .f2
+} -cleanup {
+ deleteWindows
+} -result 18
+test panedwindow-21.13 {ArrangePanes, panedwindow resizes} -setup {
+ deleteWindows
+} -body {
panedwindow .p -width 200 -borderwidth 0
frame .f1 -height 50 -bg blue
set result [list]
@@ -1913,12 +4473,12 @@ test panedwindow-22.14 {ArrangePanes, panedwindow resizes} {
.p add .f1
pack .p
lappend result [winfo reqwidth .p] [winfo reqheight .p]
- }
- -cleanup {destroy .p .f1}
- -result {200 1 200 50}
-}
-test panedwindow-22.15 {ArrangePanes, panedwindow resizes} {
- -body {
+} -cleanup {
+ deleteWindows
+} -result {200 1 200 50}
+test panedwindow-21.14 {ArrangePanes, panedwindow resizes} -setup {
+ deleteWindows
+} -body {
panedwindow .p -height 200 -borderwidth 0 -orient vertical
frame .f1 -width 50 -bg blue
set result [list]
@@ -1926,12 +4486,12 @@ test panedwindow-22.15 {ArrangePanes, panedwindow resizes} {
.p add .f1
pack .p
lappend result [winfo reqwidth .p] [winfo reqheight .p]
- }
- -cleanup {destroy .p .f1}
- -result {1 200 50 200}
-}
-test panedwindow-22.16 {ArrangePanes, last pane grows} {
- -body {
+} -cleanup {
+ deleteWindows
+} -result {1 200 50 200}
+test panedwindow-21.15 {ArrangePanes, last pane grows} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -height 50
.p add [frame .f1 -width 50 -bg red] [frame .f2 -width 50 -bg white] \
[frame .f3 -width 50 -bg blue] [frame .f4 -width 50 -bg green]
@@ -1945,13 +4505,14 @@ test panedwindow-22.16 {ArrangePanes, last pane grows} {
update
lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \
[winfo width .f4] [winfo width .p]
- }
- -cleanup {destroy .p .f1 .f2 .f3 .f4}
- -result {50 150 1 1 211 50 150 1 89 300}
-}
+} -cleanup {
+ deleteWindows
+} -result {50 150 1 1 211 50 150 1 89 300}
-test panedwindow-23.1 {PanedWindowReqProc, react to slave geometry changes} {
+test panedwindow-22.1 {PanedWindowReqProc, react to slave geometry changes} -setup {
+ deleteWindows
+} -body {
# Basically just want to make sure that the PanedWindowReqProc is called
panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 2
.p add [frame .f1 -width 20 -height 20 -bg blue] \
@@ -1959,10 +4520,12 @@ test panedwindow-23.1 {PanedWindowReqProc, react to slave geometry changes} {
set result [winfo reqheight .p]
.f1 configure -height 80
lappend result [winfo reqheight .p]
- destroy .p .f1 .f2
- set result
-} {40 80}
-test panedwindow-23.2 {PanedWindowReqProc, react to slave geometry changes} {
+} -cleanup {
+ deleteWindows
+} -result {40 80}
+test panedwindow-22.2 {PanedWindowReqProc, react to slave geometry changes} -setup {
+ deleteWindows
+} -body {
panedwindow .p -orient horizontal -sashpad 0 -sashwidth 2
.p add [frame .f1 -width 10] [frame .f2 -width 10]
set result [winfo reqwidth .p]
@@ -1970,111 +4533,139 @@ test panedwindow-23.2 {PanedWindowReqProc, react to slave geometry changes} {
lappend result [winfo reqwidth .p]
destroy .p .f1 .f2
expr {[lindex $result 1] - [lindex $result 0]}
-} {10}
+} -cleanup {
+ deleteWindows
+} -result {10}
-test panedwindow-24.1 {ConfigurePanes, can't add panedwindow to itself} {
+test panedwindow-23.1 {ConfigurePanes, can't add panedwindow to itself} -setup {
+ deleteWindows
+} -body {
panedwindow .p
- set result [list [catch {.p add .p} msg] $msg]
- destroy .p
- set result
-} [list 1 "can't add .p to itself"]
-test panedwindow-24.2 {ConfigurePanes, bad window throws error} {
+ .p add .p
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {can't add .p to itself}
+test panedwindow-23.2 {ConfigurePanes, bad window throws error} -setup {
+ deleteWindows
+} -body {
panedwindow .p
- set result [list [catch {.p add .b} msg] $msg]
- destroy .p
- set result
-} [list 1 "bad window path name \".b\""]
-test panedwindow-24.3 {ConfigurePanes, bad window aborts processing} {
+ .p add .b
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {bad window path name ".b"}
+test panedwindow-23.3 {ConfigurePanes, bad window aborts processing} -setup {
+ deleteWindows
+} -body {
panedwindow .p
button .b
catch {.p add .b .a}
- set result [.p panes]
- destroy .p .b
- set result
-} {}
-test panedwindow-24.4 {ConfigurePanes, bad option aborts processing} {
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {}
+test panedwindow-23.4 {ConfigurePanes, bad option aborts processing} -setup {
+ deleteWindows
+} -body {
panedwindow .p
button .b
catch {.p add .b -sticky foobar}
- set result [.p panes]
- destroy .p .b
- set result
-} {}
-test panedwindow-24.5 {ConfigurePanes, after win isn't managed by panedwin} {
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {}
+test panedwindow-23.5 {ConfigurePanes, after win isn't managed by panedwin} -setup {
+ deleteWindows
+} -body {
panedwindow .p
button .b
button .c
- set result [list [catch {.p add .b -after .c} msg] $msg]
- destroy .p .b .c
- set result
-} [list 1 "window \".c\" is not managed by .p"]
-test panedwindow-24.6 {ConfigurePanes, before win isn't managed by panedwin} {
+ .p add .b -after .c
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {window ".c" is not managed by .p}
+test panedwindow-23.6 {ConfigurePanes, before win isn't managed by panedwin} -setup {
+ deleteWindows
+} -body {
panedwindow .p
button .b
button .c
- set result [list [catch {.p add .b -before .c} msg] $msg]
- destroy .p .b .c
- set result
-} [list 1 "window \".c\" is not managed by .p"]
-test panedwindow-24.7 {ConfigurePanes, -after {} is a no-op} {
+ .p add .b -before .c
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {window ".c" is not managed by .p}
+test panedwindow-23.7 {ConfigurePanes, -after {} is a no-op} -setup {
+ deleteWindows
+} -body {
panedwindow .p
.p add [button .b] [button .c]
.p paneconfigure .b -after {}
- set result [.p panes]
- destroy .p .b .c
- set result
-} {.b .c}
-test panedwindow-24.8 {ConfigurePanes, -before {} is a no-op} {
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.b .c}
+test panedwindow-23.8 {ConfigurePanes, -before {} is a no-op} -setup {
+ deleteWindows
+} -body {
panedwindow .p
.p add [button .b] [button .c]
.p paneconfigure .b -before {}
- set result [.p panes]
- destroy .p .b .c
- set result
-} {.b .c}
-test panedwindow-24.9 {ConfigurePanes, new panes are added} {
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.b .c}
+test panedwindow-23.9 {ConfigurePanes, new panes are added} -setup {
+ deleteWindows
+} -body {
panedwindow .p
.p add [button .b] [button .c]
- set result [.p panes]
- destroy .p .b .c
- set result
-} {.b .c}
-test panedwindow-24.10 {ConfigurePanes, options applied to all panes} {
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.b .c}
+test panedwindow-23.10 {ConfigurePanes, options applied to all panes} -setup {
+ deleteWindows
+} -body {
panedwindow .p
.p add [button .b] [button .c] -sticky ne -height 5 -width 5 -minsize 10
set result {}
foreach w {.b .c} {
- set val {}
- foreach option {-sticky -height -width -minsize} {
- lappend val $option [.p panecget $w $option]
- }
- lappend result $w $val
+ set val {}
+ foreach option {-sticky -height -width -minsize} {
+ lappend val $option [.p panecget $w $option]
+ }
+ lappend result $w $val
}
- destroy .p .b .c
- set result
-} [list .b {-sticky ne -height 5 -width 5 -minsize 10} \
- .c {-sticky ne -height 5 -width 5 -minsize 10}]
-test panedwindow-24.11 {ConfigurePanes, existing panes are reconfigured} {
+ return $result
+} -cleanup {
+ deleteWindows
+} -result {.b {-sticky ne -height 5 -width 5 -minsize 10} .c {-sticky ne -height 5 -width 5 -minsize 10}}
+
+test panedwindow-23.11 {ConfigurePanes, existing panes are reconfigured} -setup {
+ deleteWindows
+} -body {
panedwindow .p
.p add [button .b] -sticky nw -height 10
.p add .b [button .c] -sticky se -height 2
- set result [list [.p panes] \
- [.p panecget .b -sticky] [.p panecget .b -height] \
- [.p panecget .c -sticky] [.p panecget .c -height]]
- destroy .p .b .c
- set result
-} [list {.b .c} es 2 es 2]
-test panedwindow-24.12 {ConfigurePanes, widgets added to end by default} {
+ list [.p panes] [.p panecget .b -sticky] [.p panecget .b -height] \
+ [.p panecget .c -sticky] [.p panecget .c -height]
+} -cleanup {
+ deleteWindows
+} -result [list {.b .c} es 2 es 2]
+test panedwindow-23.12 {ConfigurePanes, widgets added to end by default} -setup {
+ deleteWindows
+} -body {
panedwindow .p
.p add [button .b]
.p add [button .c]
.p add [button .d]
- set result [.p panes]
- destroy .p .b .c .d
- set result
-} {.b .c .d}
-test panedwindow-24.13 {ConfigurePanes, -after, single addition} {
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.b .c .d}
+test panedwindow-23.13 {ConfigurePanes, -after, single addition} -setup {
+ deleteWindows
+} -body {
panedwindow .p
button .a
button .b
@@ -2082,11 +4673,13 @@ test panedwindow-24.13 {ConfigurePanes, -after, single addition} {
.p add .a .b
.p add .c -after .a
- set result [.p panes]
- destroy .p .a .b .c
- set result
-} {.a .c .b}
-test panedwindow-24.14 {ConfigurePanes, -after, multiple additions} {
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.a .c .b}
+test panedwindow-23.14 {ConfigurePanes, -after, multiple additions} -setup {
+ deleteWindows
+} -body {
panedwindow .p
button .a
button .b
@@ -2095,11 +4688,13 @@ test panedwindow-24.14 {ConfigurePanes, -after, multiple additions} {
.p add .a .b
.p add .c .d -after .a
- set result [.p panes]
- destroy .p .a .b .c .d
- set result
-} {.a .c .d .b}
-test panedwindow-24.15 {ConfigurePanes, -after, relocates existing widget} {
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.a .c .d .b}
+test panedwindow-23.15 {ConfigurePanes, -after, relocates existing widget} -setup {
+ deleteWindows
+} -body {
panedwindow .p
button .a
button .b
@@ -2108,11 +4703,13 @@ test panedwindow-24.15 {ConfigurePanes, -after, relocates existing widget} {
.p add .a .b .c .d
.p add .d -after .a
- set result [.p panes]
- destroy .p .a .b .c .d
- set result
-} {.a .d .b .c}
-test panedwindow-24.16 {ConfigurePanes, -after, relocates existing widgets} {
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.a .d .b .c}
+test panedwindow-23.16 {ConfigurePanes, -after, relocates existing widgets} -setup {
+ deleteWindows
+} -body {
panedwindow .p
button .a
button .b
@@ -2121,11 +4718,13 @@ test panedwindow-24.16 {ConfigurePanes, -after, relocates existing widgets} {
.p add .a .b .c .d
.p add .b .d -after .a
- set result [.p panes]
- destroy .p .a .b .c .d
- set result
-} {.a .b .d .c}
-test panedwindow-24.17 {ConfigurePanes, -after, relocates existing widgets} {
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.a .b .d .c}
+test panedwindow-23.17 {ConfigurePanes, -after, relocates existing widgets} -setup {
+ deleteWindows
+} -body {
panedwindow .p
button .a
button .b
@@ -2134,11 +4733,13 @@ test panedwindow-24.17 {ConfigurePanes, -after, relocates existing widgets} {
.p add .a .b .c .d
.p add .d .a -after .b
- set result [.p panes]
- destroy .p .a .b .c .d
- set result
-} {.b .d .a .c}
-test panedwindow-24.18 {ConfigurePanes, -after, relocates existing widgets} {
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.b .d .a .c}
+test panedwindow-23.18 {ConfigurePanes, -after, relocates existing widgets} -setup {
+ deleteWindows
+} -body {
panedwindow .p
button .a
button .b
@@ -2147,11 +4748,13 @@ test panedwindow-24.18 {ConfigurePanes, -after, relocates existing widgets} {
.p add .a .b .c .d
.p add .d .a -after .a
- set result [.p panes]
- destroy .p .a .b .c .d
- set result
-} {.d .a .b .c}
-test panedwindow-24.19 {ConfigurePanes, -after, after last window} {
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.d .a .b .c}
+test panedwindow-23.19 {ConfigurePanes, -after, after last window} -setup {
+ deleteWindows
+} -body {
panedwindow .p
button .a
button .b
@@ -2160,11 +4763,13 @@ test panedwindow-24.19 {ConfigurePanes, -after, after last window} {
.p add .a .b .c
.p add .d -after .c
- set result [.p panes]
- destroy .p .a .b .c .d
- set result
-} {.a .b .c .d}
-test panedwindow-24.20 {ConfigurePanes, -before, before first window} {
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.a .b .c .d}
+test panedwindow-23.20 {ConfigurePanes, -before, before first window} -setup {
+ deleteWindows
+} -body {
panedwindow .p
button .a
button .b
@@ -2173,11 +4778,13 @@ test panedwindow-24.20 {ConfigurePanes, -before, before first window} {
.p add .a .b .c
.p add .d -before .a
- set result [.p panes]
- destroy .p .a .b .c .d
- set result
-} {.d .a .b .c}
-test panedwindow-24.21 {ConfigurePanes, -before, relocate existing windows} {
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.d .a .b .c}
+test panedwindow-23.21 {ConfigurePanes, -before, relocate existing windows} -setup {
+ deleteWindows
+} -body {
panedwindow .p
button .a
button .b
@@ -2186,11 +4793,13 @@ test panedwindow-24.21 {ConfigurePanes, -before, relocate existing windows} {
.p add .a .b .c
.p add .d .b -before .a
- set result [.p panes]
- destroy .p .a .b .c .d
- set result
-} {.d .b .a .c}
-test panedwindow-24.22 {ConfigurePanes, slave specified multiple times} {
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.d .b .a .c}
+test panedwindow-23.22 {ConfigurePanes, slave specified multiple times} -setup {
+ deleteWindows
+} -body {
# This test should not cause a core dump
panedwindow .p
@@ -2199,11 +4808,13 @@ test panedwindow-24.22 {ConfigurePanes, slave specified multiple times} {
button .c
.p add .a .a .b .c
- set result [.p panes]
- destroy .p .a .b .c
- set result
-} {.a .b .c}
-test panedwindow-24.23 {ConfigurePanes, slave specified multiple times} {
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.a .b .c}
+test panedwindow-23.23 {ConfigurePanes, slave specified multiple times} -setup {
+ deleteWindows
+} -body {
# This test should not cause a core dump
panedwindow .p
@@ -2213,52 +4824,63 @@ test panedwindow-24.23 {ConfigurePanes, slave specified multiple times} {
.p add .a .a .b .c
.p add .a .b .a -after .c
- set result [.p panes]
- destroy .p .a .b .c
- set result
-} {.c .a .b}
-test panedwindow-24.24 {ConfigurePanes, panedwindow cannot manage toplevels} {
+ .p panes
+} -cleanup {
+ deleteWindows
+} -result {.c .a .b}
+test panedwindow-23.24 {ConfigurePanes, panedwindow cannot manage toplevels} -setup {
+ deleteWindows
+} -body {
panedwindow .p
toplevel .t
- set result [list [catch {.p add .t} msg] $msg]
- destroy .p .t
- set result
-} [list 1 "can't add toplevel .t to .p"]
-test panedwindow-24.25 {ConfigurePanes, restrict possible panes} {
+ .p add .t
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {can't add toplevel .t to .p}
+test panedwindow-23.25 {ConfigurePanes, restrict possible panes} -setup {
+ deleteWindows
+} -body {
panedwindow .p
frame .f
button .f.b
- set result [list [catch {.p add .f.b} msg] $msg]
- destroy .p .f .f.b
- set result
-} [list 1 "can't add .f.b to .p"]
-test panedwindow-24.26 {ConfigurePanes, restrict possible panes} {
+ .p add .f.b
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {can't add .f.b to .p}
+test panedwindow-23.26 {ConfigurePanes, restrict possible panes} -setup {
+ deleteWindows
+} -body {
frame .f
panedwindow .f.p
button .b
- set result [list [catch {.f.p add .b} msg] $msg]
- destroy .f.p .f .b
- set result
-} [list 0 ""]
-test panedwindow-24.27 {ConfigurePanes, restrict possible panes} {
+ .f.p add .b
+} -cleanup {
+ deleteWindows
+} -result {}
+test panedwindow-23.27 {ConfigurePanes, restrict possible panes} -setup {
+ deleteWindows
+} -body {
panedwindow .p
button .p.b
- set result [list [catch {.p add .p.b} msg] $msg]
- destroy .p .p.b
- set result
-} [list 0 ""]
-test panedwindow-24.28 {ConfigurePanes, restrict possible panes} {
+ .p add .p.b
+} -cleanup {
+ deleteWindows
+} -result {}
+test panedwindow-23.28 {ConfigurePanes, restrict possible panes} -setup {
+ deleteWindows
+} -body {
frame .f
frame .f.f
frame .f.f.f
panedwindow .f.f.f.p
button .b
- set result [list [catch {.f.f.f.p add .b} msg] $msg]
- destroy .f .f.f .f.f.f .f.f.f.p .b
- set result
-} [list 0 ""]
-test panedwindow-24.29.1 {ConfigurePanes, -hide works} {
- -body {
+ .f.f.f.p add .b
+} -cleanup {
+ deleteWindows
+} -result {}
+test panedwindow-23.29 {ConfigurePanes, -hide works} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false
frame .f1 -width 40 -height 100 -bg red
frame .f2 -width 40 -height 100 -bg white
@@ -2278,12 +4900,12 @@ test panedwindow-24.29.1 {ConfigurePanes, -hide works} {
[winfo ismapped .f3] [winfo ismapped .f4]
lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \
[winfo width .f4] [winfo width .p]
- }
- -cleanup {destroy .p .f1 .f2 .f3 .f4}
- -result {1 1 1 1 40 40 40 40 171 1 0 1 1 40 40 40 40 128}
-}
-test panedwindow-24.29.2 {ConfigurePanes, -hide works} {
- -body {
+} -cleanup {
+ deleteWindows
+} -result {1 1 1 1 40 40 40 40 171 1 0 1 1 40 40 40 40 128}
+test panedwindow-23.30 {ConfigurePanes, -hide works} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -width 130 -height 100
frame .f1 -width 40 -bg red
frame .f2 -width 40 -bg white
@@ -2303,12 +4925,12 @@ test panedwindow-24.29.2 {ConfigurePanes, -hide works} {
[winfo ismapped .f3] [winfo ismapped .f4]
lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \
[winfo width .f4] [winfo width .p]
- }
- -cleanup {destroy .p .f1 .f2 .f3 .f4}
- -result {1 1 1 0 39 40 40 1 130 1 0 1 1 40 40 40 42 130}
-}
-test panedwindow-24.29.3 {ConfigurePanes, -hide works, last pane stretches} {
- -body {
+} -cleanup {
+ deleteWindows
+} -result {1 1 1 0 39 40 40 1 130 1 0 1 1 40 40 40 42 130}
+test panedwindow-23.31 {ConfigurePanes, -hide works, last pane stretches} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -width 200 -height 200 -borderwidth 0
frame .f1 -width 50 -bg red
frame .f2 -width 50 -bg green
@@ -2320,13 +4942,13 @@ test panedwindow-24.29.3 {ConfigurePanes, -hide works, last pane stretches} {
lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3]
.p paneconfigure .f2 -hide 1
update
- lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3]
- }
- -cleanup {destroy .p .f1 .f2 .f3}
- -result {50 50 94 50 50 147}
-}
-test panedwindow-24.29.4 {ConfigurePanes, -hide works, last pane stretches} {
- -body {
+ lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3]
+} -cleanup {
+ deleteWindows
+} -result {50 50 94 50 50 147}
+test panedwindow-23.32 {ConfigurePanes, -hide works, last pane stretches} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -width 200 -height 200 \
-borderwidth 0 -orient vertical
frame .f1 -height 50 -bg red
@@ -2340,13 +4962,13 @@ test panedwindow-24.29.4 {ConfigurePanes, -hide works, last pane stretches} {
.p paneconfigure .f2 -hide 1
update
lappend result [winfo height .f1] [winfo height .f2] [winfo height .f3]
- }
- -cleanup {destroy .p .f1 .f2 .f3}
- -result {50 50 94 50 50 147}
-}
+} -cleanup {
+ deleteWindows
+} -result {50 50 94 50 50 147}
-test panedwindow-24.30 {ConfigurePanes, -stretch first} {
- -body {
+test panedwindow-23.33 {ConfigurePanes, -stretch first} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -height 100 -width 182
frame .f1 -width 40 -bg red
frame .f2 -width 40 -bg white
@@ -2362,12 +4984,12 @@ test panedwindow-24.30 {ConfigurePanes, -stretch first} {
update
lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \
[winfo width .f4]
- }
- -cleanup {destroy .p .f1 .f2 .f3 .f4}
- -result {51 40 40 40 94 40 40 40}
-}
-test panedwindow-24.31 {ConfigurePanes, -stretch middle} {
- -body {
+} -cleanup {
+ deleteWindows
+} -result {51 40 40 40 94 40 40 40}
+test panedwindow-23.34 {ConfigurePanes, -stretch middle} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -height 100 -width 182
frame .f1 -width 40 -bg red
frame .f2 -width 40 -bg white
@@ -2383,12 +5005,12 @@ test panedwindow-24.31 {ConfigurePanes, -stretch middle} {
update
lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \
[winfo width .f4]
- }
- -cleanup {destroy .p .f1 .f2 .f3 .f4}
- -result {40 45 46 40 40 45 94 40}
-}
-test panedwindow-24.32 {ConfigurePanes, -stretch always} {
- -body {
+} -cleanup {
+ deleteWindows
+} -result {40 45 46 40 40 45 94 40}
+test panedwindow-23.35 {ConfigurePanes, -stretch always} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -height 100 -width 182
frame .f1 -width 40 -bg red
frame .f2 -width 40 -bg white
@@ -2404,12 +5026,12 @@ test panedwindow-24.32 {ConfigurePanes, -stretch always} {
update
lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \
[winfo width .f4]
- }
- -cleanup {destroy .p .f1 .f2 .f3 .f4}
- -result {42 43 43 43 58 43 58 58}
-}
-test panedwindow-24.33 {ConfigurePanes, -stretch never} {
- -body {
+} -cleanup {
+ deleteWindows
+} -result {42 43 43 43 58 43 58 58}
+test panedwindow-23.36 {ConfigurePanes, -stretch never} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -height 100 -width 182
frame .f1 -width 40 -bg red
frame .f2 -width 40 -bg white
@@ -2425,12 +5047,14 @@ test panedwindow-24.33 {ConfigurePanes, -stretch never} {
update
lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \
[winfo width .f4]
- }
- -cleanup {destroy .p .f1 .f2 .f3 .f4}
- -result {40 40 40 40 40 40 40 40}
-}
+} -cleanup {
+ deleteWindows
+} -result {40 40 40 40 40 40 40 40}
+
-test panedwindow-25.1 {Unlink, remove a paned with -before/-after refs} {
+test panedwindow-24.1 {Unlink, remove a paned with -before/-after refs} -setup {
+ deleteWindows
+} -body {
# Bug 928413
set result {}
panedwindow .pw
@@ -2445,315 +5069,386 @@ test panedwindow-25.1 {Unlink, remove a paned with -before/-after refs} {
lappend result [.pw panecget .pw.l2 -before]
.pw paneconfigure .pw.l2 -before .pw.l1
lappend result [.pw panecget .pw.l2 -before]
- destroy .pw
- set result
-} {.pw.l3 {} .pw.l1}
+} -cleanup {
+ deleteWindows
+} -result {.pw.l3 {} .pw.l1}
-test panedwindow-26.1 {DestroyPanedWindow} {
+
+test panedwindow-25.1 {DestroyPanedWindow} -setup {
+ deleteWindows
+} -body {
# This test should not result in any memory leaks.
panedwindow .p
foreach w {.a .b .c .d .e .f .g .h .i .j .k .l .m .n .o .q .r .s .t} {
- .p add [button $w]
+ .p add [button $w]
}
foreach w {.a .b .c .d .e .f .g .h .i .j .k .l .m .n .o .p .q .r .s .t} {
- destroy $w
+ destroy $w
}
set result {}
-} {}
+} -result {}
+
-test panedwindow-27.1 {PanedWindowIdentifyCoords} {
+test panedwindow-26.1 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
panedwindow .p -bd 0 -sashwidth 2 -sashpad 2
.p add [frame .f -bg red -width 20 -height 20] \
[frame .f2 -bg blue -width 20 -height 20]
- set result [.p identify 0 0]
- destroy .p .f .f2
- set result
-} {}
-test panedwindow-27.2 {PanedWindowIdentifyCoords, padding is included} {
+ .p identify 0 0
+} -cleanup {
+ deleteWindows
+} -result {}
+test panedwindow-26.2 {PanedWindowIdentifyCoords, padding is included} -setup {
+ deleteWindows
+} -body {
panedwindow .p -bd 0 -sashwidth 2 -sashpad 2
.p add [frame .f -bg red -width 20 -height 20] \
[frame .f2 -bg blue -width 20 -height 20]
- set result [.p identify 20 0]
- destroy .p .f .f2
- set result
-} {0 sash}
-test panedwindow-27.3 {PanedWindowIdentifyCoords} {
+ .p identify 20 0
+} -cleanup {
+ deleteWindows
+} -result {0 sash}
+test panedwindow-26.3 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
panedwindow .p -bd 0 -sashwidth 2 -sashpad 2
.p add [frame .f -bg red -width 20 -height 20] \
[frame .f2 -bg blue -width 20 -height 20]
- set result [.p identify 22 0]
- destroy .p .f .f2
- set result
-} {0 sash}
-test panedwindow-27.4 {PanedWindowIdentifyCoords} {
+ .p identify 22 0
+} -cleanup {
+ deleteWindows
+} -result {0 sash}
+test panedwindow-26.4 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
panedwindow .p -bd 0 -sashwidth 2 -sashpad 2
.p add [frame .f -bg red -width 20 -height 20] \
[frame .f2 -bg blue -width 20 -height 20]
- set result [.p identify 24 0]
- destroy .p .f .f2
- set result
-} {0 sash}
-test panedwindow-27.5 {PanedWindowIdentifyCoords} {
+ .p identify 24 0
+} -cleanup {
+ deleteWindows
+} -result {0 sash}
+test panedwindow-26.5 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
panedwindow .p -bd 0 -sashwidth 2 -sashpad 2
.p add [frame .f -bg red -width 20 -height 20] \
[frame .f2 -bg blue -width 20 -height 20]
- set result [.p identify 26 0]
- destroy .p .f .f2
- set result
-} {0 sash}
-test panedwindow-27.6 {PanedWindowIdentifyCoords} {
+ .p identify 26 0
+} -cleanup {
+ deleteWindows
+} -result {0 sash}
+test panedwindow-26.6 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
panedwindow .p -bd 0 -sashwidth 2 -sashpad 2
.p add [frame .f -bg red -width 20 -height 20] \
[frame .f2 -bg blue -width 20 -height 20]
- set result [.p identify 26 -1]
- destroy .p .f .f2
- set result
-} {}
-test panedwindow-27.7 {PanedWindowIdentifyCoords} {
+ .p identify 26 -1
+} -cleanup {
+ deleteWindows
+} -result {}
+test panedwindow-26.7 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
panedwindow .p -bd 0 -sashwidth 2 -sashpad 2
.p add [frame .f -bg red -width 20 -height 20] \
[frame .f2 -bg blue -width 20 -height 20]
- set result [.p identify 26 100]
- destroy .p .f .f2
- set result
-} {}
-test panedwindow-27.8 {PanedWindowIdentifyCoords} {
+ .p identify 26 100
+} -cleanup {
+ deleteWindows
+} -result {}
+test panedwindow-26.8 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \
-handlesize 6
.p add [frame .f -bg red -width 20 -height 20] \
[frame .f2 -bg blue -width 20 -height 20]
- set result [.p identify 22 4]
- destroy .p .f .f2
- set result
-} {0 sash}
-test panedwindow-27.9 {PanedWindowIdentifyCoords} {
+ .p identify 22 4
+} -cleanup {
+ deleteWindows
+} -result {0 sash}
+test panedwindow-26.9 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \
-handlesize 6
.p add [frame .f -bg red -width 20 -height 20] \
[frame .f2 -bg blue -width 20 -height 20]
- set result [.p identify 22 5]
- destroy .p .f .f2
- set result
-} {0 handle}
-test panedwindow-27.10 {PanedWindowIdentifyCoords} {
+ .p identify 22 5
+} -cleanup {
+ deleteWindows
+} -result {0 handle}
+test panedwindow-26.10 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \
-handlesize 8
.p add [frame .f -bg red -width 20 -height 20] \
[frame .f2 -bg blue -width 20 -height 20]
- set result [.p identify 20 5]
- destroy .p .f .f2
- set result
-} {0 handle}
-test panedwindow-27.11 {PanedWindowIdentifyCoords} {
+ .p identify 20 5
+} -cleanup {
+ deleteWindows
+} -result {0 handle}
+test panedwindow-26.11 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \
-handlesize 8
.p add [frame .f -bg red -width 20 -height 20] \
[frame .f2 -bg blue -width 20 -height 20]
- set result [.p identify 20 0]
- destroy .p .f .f2
- set result
-} {0 sash}
-test panedwindow-27.12 {PanedWindowIdentifyCoords} {
+ .p identify 20 0
+} -cleanup {
+ deleteWindows
+} -result {0 sash}
+test panedwindow-26.12 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -bd 0 -sashwidth 2 -sashpad 2
.p add [frame .f -bg red -width 20 -height 20] \
[frame .f2 -bg blue -width 20 -height 20] \
[frame .f3 -bg green -width 20 -height 20]
- set result [.p identify 48 0]
- destroy .p .f .f2 .f3
- set result
-} {1 sash}
-test panedwindow-27.13 {identify subcommand errors} {
+ .p identify 48 0
+} -cleanup {
+ deleteWindows
+} -result {1 sash}
+test panedwindow-26.13 {identify subcommand errors} -setup {
+ deleteWindows
+} -body {
panedwindow .p -borderwidth 0 -sashpad 2 -sashwidth 4
- set result [list [catch {.p identify} msg] $msg]
- destroy .p
- set result
-} [list 1 "wrong # args: should be \".p identify x y\""]
-test panedwindow-27.14 {identify subcommand errors} {
+ .p identify
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {wrong # args: should be ".p identify x y"}
+test panedwindow-26.14 {identify subcommand errors} -setup {
+ deleteWindows
+} -body {
panedwindow .p
- set result [list [catch {.p identify foo bar} msg] $msg]
- destroy .p
- set result
-} [list 1 "expected integer but got \"foo\""]
-test panedwindow-27.14a {identify subcommand errors} {
+ .p identify foo bar
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "foo"}
+test panedwindow-26.15 {identify subcommand errors} -setup {
+ deleteWindows
+} -body {
panedwindow .p
- set result [list [catch {.p identify 0 bar} msg] $msg]
- destroy .p
- set result
-} [list 1 "expected integer but got \"bar\""]
-test panedwindow-27.15 {PanedWindowIdentifyCoords} {
+ .p identify 0 bar
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {expected integer but got "bar"}
+test panedwindow-26.16 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical
.p add [frame .f -bg red -width 20 -height 20] \
[frame .f2 -bg blue -width 20 -height 20]
- set result [.p identify 0 0]
- destroy .p .f .f2
- set result
-} {}
-test panedwindow-27.16 {PanedWindowIdentifyCoords, padding is included} {
+ .p identify 0 0
+} -cleanup {
+ deleteWindows
+} -result {}
+test panedwindow-26.17 {PanedWindowIdentifyCoords, padding is included} -setup {
+ deleteWindows
+} -body {
panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical
.p add [frame .f -bg red -width 20 -height 20] \
[frame .f2 -bg blue -width 20 -height 20]
- set result [.p identify 0 20]
- destroy .p .f .f2
- set result
-} {0 sash}
-test panedwindow-27.17 {PanedWindowIdentifyCoords} {
+ .p identify 0 20
+} -cleanup {
+ deleteWindows
+} -result {0 sash}
+test panedwindow-26.18 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical
.p add [frame .f -bg red -width 20 -height 20] \
[frame .f2 -bg blue -width 20 -height 20]
- set result [.p identify 0 22]
- destroy .p .f .f2
- set result
-} {0 sash}
-test panedwindow-27.18 {PanedWindowIdentifyCoords} {
+ .p identify 0 22
+} -cleanup {
+ deleteWindows
+} -result {0 sash}
+test panedwindow-26.19 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical
.p add [frame .f -bg red -width 20 -height 20] \
[frame .f2 -bg blue -width 20 -height 20]
- set result [.p identify 0 24]
- destroy .p .f .f2
- set result
-} {0 sash}
-test panedwindow-27.19 {PanedWindowIdentifyCoords} {
+ .p identify 0 24
+} -cleanup {
+ deleteWindows
+} -result {0 sash}
+test panedwindow-26.20 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical
.p add [frame .f -bg red -width 20 -height 20] \
[frame .f2 -bg blue -width 20 -height 20]
- set result [.p identify 0 26]
- destroy .p .f .f2
- set result
-} {0 sash}
-test panedwindow-27.20 {PanedWindowIdentifyCoords} {
+ .p identify 0 26
+} -cleanup {
+ deleteWindows
+} -result {0 sash}
+test panedwindow-26.21 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical
.p add [frame .f -bg red -width 20 -height 20] \
[frame .f2 -bg blue -width 20 -height 20]
- set result [.p identify -1 26]
- destroy .p .f .f2
- set result
-} {}
-test panedwindow-27.21 {PanedWindowIdentifyCoords} {
+ .p identify -1 26
+} -cleanup {
+ deleteWindows
+} -result {}
+test panedwindow-26.22 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical
.p add [frame .f -bg red -width 20 -height 20] \
[frame .f2 -bg blue -width 20 -height 20]
- set result [.p identify 100 26]
- destroy .p .f .f2
- set result
-} {}
-test panedwindow-27.22 {PanedWindowIdentifyCoords} {
+ .p identify 100 26
+} -cleanup {
+ deleteWindows
+} -result {}
+test panedwindow-26.23 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \
-handlesize 6 -orient vertical
.p add [frame .f -bg red -width 20 -height 20] \
[frame .f2 -bg blue -width 20 -height 20]
- set result [.p identify 4 22]
- destroy .p .f .f2
- set result
-} {0 sash}
-test panedwindow-27.23 {PanedWindowIdentifyCoords} {
+ .p identify 4 22
+} -cleanup {
+ deleteWindows
+} -result {0 sash}
+test panedwindow-26.24 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \
-handlesize 6 -orient vertical
.p add [frame .f -bg red -width 20 -height 20] \
[frame .f2 -bg blue -width 20 -height 20]
- set result [.p identify 5 22]
- destroy .p .f .f2
- set result
-} {0 handle}
-test panedwindow-27.24 {PanedWindowIdentifyCoords} {
+ .p identify 5 22
+} -cleanup {
+ deleteWindows
+} -result {0 handle}
+test panedwindow-26.25 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \
-handlesize 8 -orient vertical
.p add [frame .f -bg red -width 20 -height 20] \
[frame .f2 -bg blue -width 20 -height 20]
- set result [.p identify 5 20]
- destroy .p .f .f2
- set result
-} {0 handle}
-test panedwindow-27.25 {PanedWindowIdentifyCoords} {
+ .p identify 5 20
+} -cleanup {
+ deleteWindows
+} -result {0 handle}
+test panedwindow-26.26 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \
-handlesize 8 -orient vertical
.p add [frame .f -bg red -width 20 -height 20] \
[frame .f2 -bg blue -width 20 -height 20]
- set result [.p identify 0 20]
- destroy .p .f .f2
- set result
-} {0 sash}
-test panedwindow-27.26 {PanedWindowIdentifyCoords} {
+ .p identify 0 20
+} -cleanup {
+ deleteWindows
+} -result {0 sash}
+test panedwindow-26.27 {PanedWindowIdentifyCoords} -setup {
+ deleteWindows
+} -body {
panedwindow .p -showhandle false -bd 0 -sashwidth 2 -sashpad 2 -orient vertical
.p add [frame .f -bg red -width 20 -height 20] \
[frame .f2 -bg blue -width 20 -height 20] \
[frame .f3 -bg green -width 20 -height 20]
- set result [.p identify 0 48]
- destroy .p .f .f2 .f3
- set result
-} {1 sash}
-
-test panedwindow-28.1 {destroy the window cleanly on error [Bug #616589]} {
- list [catch {panedwindow .p -bogusopt bogus} msg] $msg
-} {1 {unknown option "-bogusopt"}}
-test panedwindow-28.2 {destroy the window cleanly on rename [Bug #616589]} {
+ .p identify 0 48
+} -cleanup {
+ deleteWindows
+} -result {1 sash}
+
+
+test panedwindow-27.1 {destroy the window cleanly on error [Bug #616589]} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -bogusopt bogus
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {unknown option "-bogusopt"}
+test panedwindow-27.2 {destroy the window cleanly on rename [Bug #616589]} -setup {
+ deleteWindows
+} -body {
destroy .p
panedwindow .p
rename .p {}
winfo exists .p
-} {0}
-
-
-test panedwindow-29.1 {resizing width} {
- -body {
- panedwindow .p -bd 5
- frame .f1 -width 100 -height 50 -bg blue
- frame .f2 -width 100 -height 50 -bg red
-
- .p add .f1 -sticky news
- .p add .f2 -sticky news
- pack .p -side top -fill both -expand 1
- wm geometry . ""
- update
- # Note the width
- set a [winfo width .f2]
- # Increase the size by 10
- regexp {^(\d+)x(\d+)} [wm geometry .] -> w h
- wm geometry . [expr {$w + 10}]x$h
- update
- set b "$a [winfo width .f2]"
- }
- -cleanup {destroy .p .f1 .f2}
- -result {100 110}
-}
-
-test panedwindow-29.2 {resizing height} {
- -body {
- panedwindow .p -orient vertical -bd 5
- frame .f1 -width 50 -height 100 -bg blue
- frame .f2 -width 50 -height 100 -bg red
-
- .p add .f1 -sticky news
- .p add .f2 -sticky news
- pack .p -side top -fill both -expand 1
- wm geometry . ""
- update
- # Note the height
- set a [winfo height .f2]
- # Increase the size by 10
- regexp {^(\d+)x(\d+)} [wm geometry .] -> w h
- wm geometry . ${w}x[expr {$h + 10}]
- update
- set b "$a [winfo height .f2]"
- }
- -cleanup {destroy .p .f1 .f2}
- -result {100 110}
-}
-
-test panedwindow-30.1 {display on depths other than the default one} {
- -constraints {pseudocolor8 haveTruecolor24}
- -body {
+} -cleanup {
+ deleteWindows
+} -result {0}
+
+
+test panedwindow-28.1 {resizing width} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -bd 5
+ frame .f1 -width 100 -height 50 -bg blue
+ frame .f2 -width 100 -height 50 -bg red
+
+ .p add .f1 -sticky news
+ .p add .f2 -sticky news
+ pack .p -side top -fill both -expand 1
+ wm geometry . ""
+ update
+ # Note the width
+ set a [winfo width .f2]
+ # Increase the size by 10
+ regexp {^(\d+)x(\d+)} [wm geometry .] -> w h
+ wm geometry . [expr {$w + 10}]x$h
+ update
+ set b "$a [winfo width .f2]"
+} -cleanup {
+ deleteWindows
+} -result {100 110}
+
+test panedwindow-28.2 {resizing height} -setup {
+ deleteWindows
+} -body {
+ panedwindow .p -orient vertical -bd 5
+ frame .f1 -width 50 -height 100 -bg blue
+ frame .f2 -width 50 -height 100 -bg red
+
+ .p add .f1 -sticky news
+ .p add .f2 -sticky news
+ pack .p -side top -fill both -expand 1
+ wm geometry . ""
+ update
+ # Note the height
+ set a [winfo height .f2]
+ # Increase the size by 10
+ regexp {^(\d+)x(\d+)} [wm geometry .] -> w h
+ wm geometry . ${w}x[expr {$h + 10}]
+ update
+ set b "$a [winfo height .f2]"
+} -cleanup {
+ deleteWindows
+} -result {100 110}
+
+
+test panedwindow-29.1 {display on depths other than the default one} -constraints {
+ pseudocolor8 haveTruecolor24
+} -setup {
+ deleteWindows
+} -body {
toplevel .t -visual {truecolor 24}
pack [panedwindow .t.p]
.t.p add [frame .t.p.f1] [frame .t.p.f2]
update
# If we got here, we didn't crash and that's good
- }
- -cleanup {destroy .t}
- -result {}
-}
-test panedwindow-30.2 {display on depths other than the default one} {
- -constraints {pseudocolor8 haveTruecolor24}
- -body {
+} -cleanup {
+ deleteWindows
+} -result {}
+test panedwindow-29.2 {display on depths other than the default one} -constraints {
+ pseudocolor8 haveTruecolor24
+} -setup {
+ deleteWindows
+} -body {
toplevel .t -visual {pseudocolor 8}
pack [frame .t.f -visual {truecolor 24}]
pack [panedwindow .t.f.p]
@@ -2764,11 +5459,13 @@ test panedwindow-30.2 {display on depths other than the default one} {
.t.f.p proxy forget
update
# If we got here, we didn't crash and that's good
- }
- -cleanup {destroy .t}
- -result {}
-}
+} -cleanup {
+ deleteWindows
+} -result {}
+
# cleanup
cleanupTests
return
+
+
diff --git a/tests/place.test b/tests/place.test
index ac2ece7..ddfa64c 100644
--- a/tests/place.test
+++ b/tests/place.test
@@ -5,7 +5,8 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
@@ -15,6 +16,7 @@ testConstraint memory [llength [info commands memory]]
# XXX - This test file is woefully incomplete. At present, only a
# few of the features are tested.
+# Widgets used in tests 1.* - 8.*
toplevel .t -width 300 -height 200 -bd 0
wm geom .t +0+0
frame .t.f -width 154 -height 84 -bd 2 -relief raised
@@ -22,145 +24,181 @@ place .t.f -x 48 -y 38
frame .t.f2 -width 30 -height 60 -bd 2 -relief raised
update
-test place-1.1 {Tk_PlaceCmd procedure, "info" option} {
+test place-1.1 {Tk_PlaceCmd procedure, "info" option} -setup {
+ place forget .t.f2
+} -body {
place .t.f2 -x 0
place info .t.f2
-} {-in .t -x 0 -relx 0 -y 0 -rely 0 -width {} -relwidth {} -height {} -relheight {} -anchor nw -bordermode inside}
-test place-1.2 {Tk_PlaceCmd procedure, "info" option} {
+} -result {-in .t -x 0 -relx 0 -y 0 -rely 0 -width {} -relwidth {} -height {} -relheight {} -anchor nw -bordermode inside}
+test place-1.2 {Tk_PlaceCmd procedure, "info" option} -setup {
+ place forget .t.f2
+} -body {
place .t.f2 -x 1 -y 2 -width 3 -height 4 -relx 0.1 -rely 0.2 \
- -relwidth 0.3 -relheight 0.4 -anchor se -in .t.f \
- -bordermode outside
+ -relwidth 0.3 -relheight 0.4 -anchor se -in .t.f \
+ -bordermode outside
place info .t.f2
-} {-in .t.f -x 1 -relx 0.1 -y 2 -rely 0.2 -width 3 -relwidth 0.3 -height 4 -relheight 0.4 -anchor se -bordermode outside}
-test place-1.3 {Tk_PlaceCmd procedure, "info" option} {
+} -result {-in .t.f -x 1 -relx 0.1 -y 2 -rely 0.2 -width 3 -relwidth 0.3 -height 4 -relheight 0.4 -anchor se -bordermode outside}
+test place-1.3 {Tk_PlaceCmd procedure, "info" option} -setup {
+ place forget .t.f2
+ destroy .t.a.b
+} -body {
# Make sure the result is built as a proper list by using a space in parent
frame ".t.a b"
place .t.f2 -x 1 -y 2 -width {} -height 4 -relx 0.2 -rely 0.2 \
- -relwidth 0.3 -relheight {} -anchor w -in ".t.a b" \
- -bordermode ignore
- set res [place info .t.f2]
- destroy ".t.a b"
- set res
-} {-in {.t.a b} -x 1 -relx 0.2 -y 2 -rely 0.2 -width {} -relwidth 0.3 -height 4 -relheight {} -anchor w -bordermode ignore}
-
-test place-2.1 {ConfigureSlave procedure, -height option} {
- list [catch {place .t.f2 -height abcd} msg] $msg
-} {1 {bad screen distance "abcd"}}
-test place-2.2 {ConfigureSlave procedure, -height option} {
+ -relwidth 0.3 -relheight {} -anchor w -in ".t.a b" \
+ -bordermode ignore
+ place info .t.f2
+} -cleanup {
+ destroy ".t.a.b"
+} -result {-in {.t.a b} -x 1 -relx 0.2 -y 2 -rely 0.2 -width {} -relwidth 0.3 -height 4 -relheight {} -anchor w -bordermode ignore}
+
+
+test place-2.1 {ConfigureSlave procedure, -height option} -body {
+ place .t.f2 -height abcd
+} -returnCodes error -result {bad screen distance "abcd"}
+test place-2.2 {ConfigureSlave procedure, -height option} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -height 40
update
winfo height .t.f2
-} {40}
-test place-2.3 {ConfigureSlave procedure, -height option} {
+} -result {40}
+test place-2.3 {ConfigureSlave procedure, -height option} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -height 120
update
place .t.f2 -height {}
update
winfo height .t.f2
-} {60}
+} -result {60}
-test place-3.1 {ConfigureSlave procedure, -relheight option} {
- list [catch {place .t.f2 -relheight abcd} msg] $msg
-} {1 {expected floating-point number but got "abcd"}}
-test place-3.2 {ConfigureSlave procedure, -relheight option} {
+
+test place-3.1 {ConfigureSlave procedure, -relheight option} -body {
+ place .t.f2 -relheight abcd
+} -returnCodes error -result {expected floating-point number but got "abcd"}
+test place-3.2 {ConfigureSlave procedure, -relheight option} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -relheight .5
update
winfo height .t.f2
-} {40}
-test place-3.3 {ConfigureSlave procedure, -relheight option} {
+} -result {40}
+test place-3.3 {ConfigureSlave procedure, -relheight option} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -relheight .8
update
place .t.f2 -relheight {}
update
winfo height .t.f2
-} {60}
+} -result {60}
+
-test place-4.1 {ConfigureSlave procedure, bad -in options} {
+test place-4.1 {ConfigureSlave procedure, bad -in options} -setup {
+ place forget .t.f2
+} -body {
+ place .t.f2 -in .t.f2
+} -returnCodes error -result {can't place .t.f2 relative to itself}
+test place-4.2 {ConfigureSlave procedure, bad -in option} -setup {
place forget .t.f2
- list [catch {place .t.f2 -in .t.f2} msg] $msg
-} [list 1 "can't place .t.f2 relative to itself"]
-test place-4.2 {ConfigureSlave procedure, bad -in option} {
+} -body {
+ set result [list [winfo manager .t.f2]]
+ catch {place .t.f2 -in .t.f2}
+ lappend result [winfo manager .t.f2]
+} -result {{} {}}
+test place-4.3 {ConfigureSlave procedure, bad -in option} -setup {
place forget .t.f2
- list [winfo manager .t.f2] \
- [catch {place .t.f2 -in .t.f2} err] $err \
- [winfo manager .t.f2]
-} {{} 1 {can't place .t.f2 relative to itself} {}}
-test place-4.3 {ConfigureSlave procedure, bad -in option} {
+} -body {
+ winfo manager .t.f2
+ place .t.f2 -in .t.f2
+} -returnCodes error -result {can't place .t.f2 relative to itself}
+test place-4.4 {ConfigureSlave procedure, bad -in option} -setup {
place forget .t.f2
- list [catch {place .t.f2 -in .} msg] $msg
-} [list 1 "can't place .t.f2 relative to ."]
+} -body {
+ place .t.f2 -in .
+} -returnCodes error -result {can't place .t.f2 relative to .}
-test place-5.1 {ConfigureSlave procedure, -relwidth option} {
- list [catch {place .t.f2 -relwidth abcd} msg] $msg
-} {1 {expected floating-point number but got "abcd"}}
-test place-5.2 {ConfigureSlave procedure, -relwidth option} {
+
+test place-5.1 {ConfigureSlave procedure, -relwidth option} -body {
+ place .t.f2 -relwidth abcd
+} -returnCodes error -result {expected floating-point number but got "abcd"}
+test place-5.2 {ConfigureSlave procedure, -relwidth option} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -relwidth .5
update
winfo width .t.f2
-} {75}
-test place-5.3 {ConfigureSlave procedure, -relwidth option} {
+} -result {75}
+test place-5.3 {ConfigureSlave procedure, -relwidth option} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -relwidth .8
update
place .t.f2 -relwidth {}
update
winfo width .t.f2
-} {30}
+} -result {30}
-test place-6.1 {ConfigureSlave procedure, -width option} {
- list [catch {place .t.f2 -width abcd} msg] $msg
-} {1 {bad screen distance "abcd"}}
-test place-6.2 {ConfigureSlave procedure, -width option} {
+test place-6.1 {ConfigureSlave procedure, -width option} -body {
+ place .t.f2 -width abcd
+} -returnCodes error -result {bad screen distance "abcd"}
+test place-6.2 {ConfigureSlave procedure, -width option} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -width 100
update
winfo width .t.f2
-} {100}
-test place-6.3 {ConfigureSlave procedure, -width option} {
+} -result {100}
+test place-6.3 {ConfigureSlave procedure, -width option} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -width 120
update
place .t.f2 -width {}
update
winfo width .t.f2
-} {30}
+} -result {30}
+
-test place-7.1 {ReconfigurePlacement procedure, computing position} {
+test place-7.1 {ReconfigurePlacement procedure, computing position} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -x -2 -relx .5 -y 3 -rely .4
update
winfo geometry .t.f2
-} {30x60+123+75}
-test place-7.2 {ReconfigurePlacement procedure, position rounding} {
+} -result {30x60+123+75}
+test place-7.2 {ReconfigurePlacement procedure, position rounding} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -x -1.4 -y -2.3
update
winfo geometry .t.f2
-} {30x60+49+38}
-test place-7.3 {ReconfigurePlacement procedure, position rounding} {
+} -result {30x60+49+38}
+test place-7.3 {ReconfigurePlacement procedure, position rounding} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -x 1.4 -y 2.3
update
winfo geometry .t.f2
-} {30x60+51+42}
-test place-7.4 {ReconfigurePlacement procedure, position rounding} {
+} -result {30x60+51+42}
+test place-7.4 {ReconfigurePlacement procedure, position rounding} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -x -1.6 -y -2.7
update
winfo geometry .t.f2
-} {30x60+48+37}
-test place-7.5 {ReconfigurePlacement procedure, position rounding} {
+} -result {30x60+48+37}
+test place-7.5 {ReconfigurePlacement procedure, position rounding} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -x 1.6 -y 2.7
update
winfo geometry .t.f2
-} {30x60+52+43}
-test place-7.6 {ReconfigurePlacement procedure, position rounding} {
+} -result {30x60+52+43}
+test place-7.6 {ReconfigurePlacement procedure, position rounding} -setup {
+ destroy .t.f3
+} -body {
frame .t.f3 -width 100 -height 100 -bg #f00000 -bd 0
place .t.f3 -x 0 -y 0
raise .t.f2
@@ -168,38 +206,44 @@ test place-7.6 {ReconfigurePlacement procedure, position rounding} {
place .t.f2 -in .t.f3 -relx .303 -rely .406 -relwidth .304 -relheight .206
update
winfo geometry .t.f2
-} {31x20+30+41}
-catch {destroy .t.f3}
-test place-7.7 {ReconfigurePlacement procedure, computing size} {
+} -cleanup {
+ destroy .t.f3
+} -result {31x20+30+41}
+test place-7.7 {ReconfigurePlacement procedure, computing size} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -width 120 -height 89
update
list [winfo width .t.f2] [winfo height .t.f2]
-} {120 89}
-test place-7.8 {ReconfigurePlacement procedure, computing size} {
+} -result {120 89}
+test place-7.8 {ReconfigurePlacement procedure, computing size} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -relwidth .4 -relheight .5
update
list [winfo width .t.f2] [winfo height .t.f2]
-} {60 40}
-test place-7.9 {ReconfigurePlacement procedure, computing size} {
+} -result {60 40}
+test place-7.9 {ReconfigurePlacement procedure, computing size} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -width 10 -relwidth .4 -height -4 -relheight .5
update
list [winfo width .t.f2] [winfo height .t.f2]
-} {70 36}
-test place-7.10 {ReconfigurePlacement procedure, computing size} {
+} -result {70 36}
+test place-7.10 {ReconfigurePlacement procedure, computing size} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -width 10 -relwidth .4 -height -4 -relheight .5
place .t.f2 -width {} -relwidth {} -height {} -relheight {}
update
list [winfo width .t.f2] [winfo height .t.f2]
-} {30 60}
+} -result {30 60}
-test place-8.1 {MasterStructureProc, mapping and unmapping slaves} {
+test place-8.1 {MasterStructureProc, mapping and unmapping slaves} -setup {
place forget .t.f2
place forget .t.f
+} -body {
place .t.f2 -relx 1.0 -rely 1.0 -anchor sw
update
set result [winfo ismapped .t.f2]
@@ -212,10 +256,11 @@ test place-8.1 {MasterStructureProc, mapping and unmapping slaves} {
wm deiconify .t
update
lappend result [winfo ismapped .t.f2]
-} {1 0 40 30 0 1}
-test place-8.2 {MasterStructureProc, mapping and unmapping slaves} {
+} -result {1 0 40 30 0 1}
+test place-8.2 {MasterStructureProc, mapping and unmapping slaves} -setup {
place forget .t.f2
place forget .t.f
+} -body {
place .t.f -x 0 -y 0 -width 200 -height 100
place .t.f2 -in .t.f -relx 1.0 -rely 1.0 -anchor sw -width 50 -height 20
update
@@ -229,130 +274,153 @@ test place-8.2 {MasterStructureProc, mapping and unmapping slaves} {
wm deiconify .t
update
lappend result [winfo ismapped .t.f2]
-} {1 0 42 32 0 1}
-
-test place-9.1 {PlaceObjCmd} {
- list [catch {place} msg] $msg
-} [list 1 "wrong # args: should be \"place option|pathName args\""]
-test place-9.2 {PlaceObjCmd} {
- list [catch {place foo} msg] $msg
-} [list 1 "wrong # args: should be \"place option|pathName args\""]
-test place-9.3 {PlaceObjCmd} {
- catch {destroy .foo}
- list [catch {place .foo bar} msg] $msg
-} [list 1 "bad window path name \".foo\""]
-test place-9.4 {PlaceObjCmd} {
- catch {destroy .foo}
- list [catch {place bar .foo} msg] $msg
-} [list 1 "bad window path name \".foo\""]
-test place-9.5 {PlaceObjCmd} {
- catch {destroy .foo}
+} -result {1 0 42 32 0 1}
+destroy .t
+
+
+test place-9.1 {PlaceObjCmd} -body {
+ place
+} -returnCodes error -result {wrong # args: should be "place option|pathName args"}
+test place-9.2 {PlaceObjCmd} -body {
+ place foo
+} -returnCodes error -result {wrong # args: should be "place option|pathName args"}
+test place-9.3 {PlaceObjCmd} -setup {
+ destroy .foo
+} -body {
+ place .foo bar
+} -returnCodes error -result {bad window path name ".foo"}
+test place-9.4 {PlaceObjCmd} -setup {
+ destroy .foo
+} -body {
+ place bar .foo
+} -cleanup {
+ destroy .foo
+} -returnCodes error -result {bad window path name ".foo"}
+test place-9.5 {PlaceObjCmd} -setup {
+ destroy .foo
+} -body {
frame .foo
- set res [list [catch {place badopt .foo} msg] $msg]
+ place badopt .foo
+} -cleanup {
destroy .foo
- set res
-} [list 1 "bad option \"badopt\": must be configure, forget, info, or slaves"]
-test place-9.6 {PlaceObjCmd, configure errors} {
- catch {destroy .foo}
+} -returnCodes error -result {bad option "badopt": must be configure, forget, info, or slaves}
+test place-9.6 {PlaceObjCmd, configure errors} -setup {
+ destroy .foo
+} -body {
frame .foo
- set res [list [catch {place configure .foo} msg] $msg]
+ place configure .foo
+} -cleanup {
+ destroy .foo
+} -returnCodes ok -result {}
+test place-9.7 {PlaceObjCmd, configure errors} -setup {
destroy .foo
- set res
-} [list 0 ""]
-test place-9.7 {PlaceObjCmd, configure errors} {
- catch {destroy .foo}
+} -body {
frame .foo
- set res [list [catch {place configure .foo bar} msg] $msg]
+ place configure .foo bar
+} -cleanup {
+ destroy .foo
+} -returnCodes ok -result {}
+test place-9.8 {PlaceObjCmd, configure} -setup {
destroy .foo
- set res
-} [list 0 ""]
-test place-9.8 {PlaceObjCmd, configure} {
- catch {destroy .foo}
+} -body {
frame .foo
place .foo -x 0 -y 0
- set res [place configure .foo]
+ place configure .foo
+} -cleanup {
destroy .foo
- set res
-} [list {-anchor {} {} nw nw} {-bordermode {} {} inside inside} {-height {} {} {} {}} {-in {} {} {} .} {-relheight {} {} {} {}} {-relwidth {} {} {} {}} {-relx {} {} 0 0.0} {-rely {} {} 0 0.0} {-width {} {} {} {}} {-x {} {} 0 0} {-y {} {} 0 0}]
-test place-9.9 {PlaceObjCmd, configure} {
- catch {destroy .foo}
+} -result [list {-anchor {} {} nw nw} {-bordermode {} {} inside inside} {-height {} {} {} {}} {-in {} {} {} .} {-relheight {} {} {} {}} {-relwidth {} {} {} {}} {-relx {} {} 0 0.0} {-rely {} {} 0 0.0} {-width {} {} {} {}} {-x {} {} 0 0} {-y {} {} 0 0}]
+test place-9.9 {PlaceObjCmd, configure} -setup {
+ destroy .foo
+} -body {
frame .foo
place .foo -x 0 -y 0
- set res [place configure .foo -x]
+ place configure .foo -x
+} -cleanup {
+ destroy .foo
+} -result {-x {} {} 0 0}
+test place-9.10 {PlaceObjCmd, forget errors} -setup {
destroy .foo
- set res
-} [list -x {} {} 0 0]
-test place-9.10 {PlaceObjCmd, forget errors} {
- catch {destroy .foo}
+} -body {
frame .foo
- set res [list [catch {place forget .foo bar} msg] $msg]
+ place forget .foo bar
+} -cleanup {
destroy .foo
- set res
-} [list 1 "wrong # args: should be \"place forget pathName\""]
-test place-9.11 {PlaceObjCmd, info errors} {
- catch {destroy .foo}
+} -returnCodes error -result {wrong # args: should be "place forget pathName"}
+test place-9.11 {PlaceObjCmd, info errors} -setup {
+ destroy .foo
+} -body {
frame .foo
- set res [list [catch {place info .foo bar} msg] $msg]
+ place info .foo bar
+} -cleanup {
+ destroy .foo
+} -returnCodes error -result {wrong # args: should be "place info pathName"}
+test place-9.12 {PlaceObjCmd, slaves errors} -setup {
destroy .foo
- set res
-} [list 1 "wrong # args: should be \"place info pathName\""]
-test place-9.12 {PlaceObjCmd, slaves errors} {
- catch {destroy .foo}
+} -body {
frame .foo
- set res [list [catch {place slaves .foo bar} msg] $msg]
+ place slaves .foo bar
+} -cleanup {
destroy .foo
- set res
-} [list 1 "wrong # args: should be \"place slaves pathName\""]
-
-test place-10.1 {ConfigureSlave} {
- catch {destroy .foo}
+} -returnCodes error -result {wrong # args: should be "place slaves pathName"}
+
+
+test place-10.1 {ConfigureSlave} -setup {
+ destroy .foo
+} -body {
frame .foo
- set res [list [catch {place .foo -badopt} msg] $msg]
+ place .foo -badopt
+} -cleanup {
destroy .foo
- set res
-} [list 1 "unknown option \"-badopt\""]
-test place-10.2 {ConfigureSlave} {
- catch {destroy .foo}
+} -returnCodes error -result {unknown option "-badopt"}
+test place-10.2 {ConfigureSlave} -setup {
+ destroy .foo
+} -body {
frame .foo
- set res [list [catch {place .foo -anchor} msg] $msg]
+ place .foo -anchor
+} -cleanup {
+ destroy .foo
+} -returnCodes error -result {value for "-anchor" missing}
+test place-10.3 {ConfigureSlave} -setup {
destroy .foo
- set res
-} [list 1 "value for \"-anchor\" missing"]
-test place-10.3 {ConfigureSlave} {
- catch {destroy .foo}
+} -body {
frame .foo
- set res [list [catch {place .foo -bordermode j} msg] $msg]
+ place .foo -bordermode j
+} -cleanup {
+ destroy .foo
+} -returnCodes error -result {bad bordermode "j": must be inside, outside, or ignore}
+test place-10.4 {ConfigureSlave} -setup {
destroy .foo
- set res
-} [list 1 "bad bordermode \"j\": must be inside, outside, or ignore"]
-test place-10.4 {ConfigureSlave} {
- catch {destroy .foo}
+} -body {
frame .foo
- set res [list [catch {place configure .foo -x 0 -y} msg] $msg]
+ place configure .foo -x 0 -y
+} -cleanup {
+ destroy .foo
+} -returnCodes error -result {value for "-y" missing}
+
+
+test place-11.1 {PlaceObjCmd, slaves command} -setup {
destroy .foo
- set res
-} [list 1 "value for \"-y\" missing"]
-
-test place-11.1 {PlaceObjCmd, slaves command} {
- catch {destroy .foo}
+} -body {
frame .foo
- set res [place slaves .foo]
+ place slaves .foo
+} -cleanup {
destroy .foo
- set res
-} {}
-test place-11.2 {PlaceObjCmd, slaves command} {
- catch {destroy .foo .bar}
+} -result {}
+test place-11.2 {PlaceObjCmd, slaves command} -setup {
+ destroy .foo .bar
+} -body {
frame .foo
frame .bar
place .bar -in .foo
- set res [place slaves .foo]
- destroy .foo
- destroy .bar
- set res
-} [list .bar]
+ place slaves .foo
+} -cleanup {
+ destroy .foo .bar
+} -result [list .bar]
+
-test place-12.1 {PlaceObjCmd, forget command} {
- catch {destroy .foo}
+test place-12.1 {PlaceObjCmd, forget command} -setup {
+ destroy .foo
+} -body {
frame .foo
place .foo -width 50 -height 50
update
@@ -360,11 +428,14 @@ test place-12.1 {PlaceObjCmd, forget command} {
place forget .foo
update
lappend res [winfo ismapped .foo]
+} -cleanup {
destroy .foo
- set res
-} [list 1 0]
+} -result {1 0}
+
-test place-13.1 {test respect for internalborder} {
+test place-13.1 {test respect for internalborder} -setup {
+ destroy .pack
+} -body {
toplevel .pack
wm geometry .pack 200x200
frame .pack.l -width 15 -height 10
@@ -377,11 +448,13 @@ test place-13.1 {test respect for internalborder} {
.pack.lf configure -labelanchor e -padx 3 -pady 5
update
lappend res [winfo geometry .pack.lf.f]
+} -cleanup {
destroy .pack
- set res
-} {196x188+2+10 177x186+5+7}
+} -result {196x188+2+10 177x186+5+7}
-test place-14.1 {memory leak testing} -setup {
+
+test place-14.1 {memory leak testing} -constraints memory -setup {
+ destroy .f
proc getbytes {} {
set lines [split [memory info] "\n"]
lindex [lindex $lines 3] 3
@@ -400,7 +473,7 @@ test place-14.1 {memory leak testing} -setup {
}
return $res
}
-} -constraints memory -body {
+} -body {
# Test all manners of forgetting a slave
frame .f
frame .f.f
@@ -416,14 +489,16 @@ test place-14.1 {memory leak testing} -setup {
frame .f
frame .f.f
}
-} -result {0 0 0} -cleanup {
+} -cleanup {
destroy .f
rename getbytes {}
rename stress {}
-}
+} -result {0 0 0}
-catch {destroy .t}
# cleanup
cleanupTests
return
+
+
+
diff --git a/tests/raise.test b/tests/raise.test
index a17fa2e..461ccbf 100644
--- a/tests/raise.test
+++ b/tests/raise.test
@@ -8,19 +8,20 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
+namespace import -force tcltest::test
# Procedure to create a bunch of overlapping windows, which should
# make it easy to detect differences in order.
proc raise_setup {} {
foreach i [winfo child .raise] {
- destroy $i
- }
+ destroy $i
+ }
foreach i {a b c d e} {
- label .raise.$i -text $i -relief raised -bd 2
+ label .raise.$i -text $i -relief raised -bd 2
}
place .raise.a -x 20 -y 60 -width 60 -height 80
place .raise.b -x 60 -y 60 -width 60 -height 80
@@ -59,149 +60,173 @@ proc raise_makeToplevels {} {
toplevel .raise
wm geom .raise 250x200+0+0
-test raise-1.1 {preserve creation order} {
+
+test raise-1.1 {preserve creation order} -body {
raise_setup
tkwait visibility .raise.e
raise_getOrder
-} {d d d b c e e e}
-test raise-1.2 {preserve creation order} testmakeexist {
+} -result {d d d b c e e e}
+test raise-1.2 {preserve creation order} -constraints testmakeexist -body {
raise_setup
testmakeexist .raise.a
update
raise_getOrder
-} {d d d b c e e e}
-test raise-1.3 {preserve creation order} testmakeexist {
+} -result {d d d b c e e e}
+test raise-1.3 {preserve creation order} -constraints testmakeexist -body {
raise_setup
testmakeexist .raise.c
update
raise_getOrder
-} {d d d b c e e e}
-test raise-1.4 {preserve creation order} testmakeexist {
+} -result {d d d b c e e e}
+test raise-1.4 {preserve creation order} -constraints testmakeexist -body {
raise_setup
testmakeexist .raise.e
update
raise_getOrder
-} {d d d b c e e e}
-test raise-1.5 {preserve creation order} testmakeexist {
+} -result {d d d b c e e e}
+test raise-1.5 {preserve creation order} -constraints testmakeexist -body {
raise_setup
testmakeexist .raise.d .raise.c .raise.b
update
raise_getOrder
-} {d d d b c e e e}
+} -result {d d d b c e e e}
-test raise-2.1 {raise internal windows before creation} {
+
+test raise-2.1 {raise internal windows before creation} -body {
raise_setup
raise .raise.a
update
raise_getOrder
-} {a d d a c a e e}
-test raise-2.2 {raise internal windows before creation} {
+} -result {a d d a c a e e}
+test raise-2.2 {raise internal windows before creation} -body {
raise_setup
raise .raise.c
update
raise_getOrder
-} {d d c b c e e c}
-test raise-2.3 {raise internal windows before creation} {
+} -result {d d c b c e e c}
+test raise-2.3 {raise internal windows before creation} -body {
raise_setup
raise .raise.e
update
raise_getOrder
-} {d d d b c e e e}
-test raise-2.4 {raise internal windows before creation} {
+} -result {d d d b c e e e}
+test raise-2.4 {raise internal windows before creation} -body {
raise_setup
raise .raise.e .raise.a
update
raise_getOrder
-} {d d d b c e b c}
-test raise-2.5 {raise internal windows before creation} {
+} -result {d d d b c e b c}
+test raise-2.5 {raise internal windows before creation} -body {
raise_setup
raise .raise.a .raise.d
update
raise_getOrder
-} {a d d a c e e e}
+} -result {a d d a c e e e}
+
-test raise-3.1 {raise internal windows after creation} {
+test raise-3.1 {raise internal windows after creation} -body {
raise_setup
update
raise .raise.a .raise.d
raise_getOrder
-} {a d d a c e e e}
-test raise-3.2 {raise internal windows after creation} testmakeexist {
+} -result {a d d a c e e e}
+test raise-3.2 {raise internal windows after creation} -constraints {
+ testmakeexist
+} -body {
raise_setup
testmakeexist .raise.a .raise.b
raise .raise.a .raise.b
update
raise_getOrder
-} {d d d a c e e e}
-test raise-3.3 {raise internal windows after creation} testmakeexist {
+} -result {d d d a c e e e}
+test raise-3.3 {raise internal windows after creation} -constraints {
+ testmakeexist
+} -body {
raise_setup
testmakeexist .raise.a .raise.d
raise .raise.a .raise.b
update
raise_getOrder
-} {d d d a c e e e}
-test raise-3.4 {raise internal windows after creation} testmakeexist {
+} -result {d d d a c e e e}
+test raise-3.4 {raise internal windows after creation} -constraints {
+ testmakeexist
+} -body {
raise_setup
testmakeexist .raise.a .raise.c .raise.d
raise .raise.a .raise.b
update
raise_getOrder
-} {d d d a c e e e}
+} -result {d d d a c e e e}
-test raise-4.1 {raise relative to nephews} {
+
+test raise-4.1 {raise relative to nephews} -body {
raise_setup
update
frame .raise.d.child
raise .raise.a .raise.d.child
raise_getOrder
-} {a d d a c e e e}
-test raise-4.2 {raise relative to nephews} {
+} -result {a d d a c e e e}
+test raise-4.2 {raise relative to nephews} -setup {
+ destroy .raise2
+} -body {
raise_setup
update
frame .raise2
- list [catch {raise .raise.a .raise2} msg] $msg
-} {1 {can't raise ".raise.a" above ".raise2"}}
-catch {destroy .raise2}
+ raise .raise.a .raise2
+} -cleanup {
+ destroy .raise2
+} -returnCodes error -result {can't raise ".raise.a" above ".raise2"}
-test raise-5.1 {lower internal windows} {
+
+test raise-5.1 {lower internal windows} -body {
raise_setup
update
lower .raise.d
raise_getOrder
-} {a b c b c e e e}
-test raise-5.2 {lower internal windows} {
+} -result {a b c b c e e e}
+test raise-5.2 {lower internal windows} -body {
raise_setup
update
lower .raise.d .raise.b
raise_getOrder
-} {d b c b c e e e}
-test raise-5.3 {lower internal windows} {
+} -result {d b c b c e e e}
+test raise-5.3 {lower internal windows} -body {
raise_setup
update
lower .raise.a .raise.e
raise_getOrder
-} {a d d a c e e e}
-test raise-5.4 {lower internal windows} {
+} -result {a d d a c e e e}
+test raise-5.4 {lower internal windows} -setup {
+ destroy .raise2
+} -body {
raise_setup
update
frame .raise2
- list [catch {lower .raise.a .raise2} msg] $msg
-} {1 {can't lower ".raise.a" below ".raise2"}}
-catch {destroy .raise2}
+ lower .raise.a .raise2
+} -cleanup {
+ destroy .raise2
+} -returnCodes error -result {can't lower ".raise.a" below ".raise2"}
-test raise-6.1 {raise/lower toplevel windows} {nonPortable} {
+
+test raise-6.1 {raise/lower toplevel windows} -constraints {
+ nonPortable
+} -body {
raise_makeToplevels
update
raise .raise1
winfo containing [winfo rootx .raise1] [winfo rooty .raise1]
-} .raise1
-test raise-6.2 {raise/lower toplevel windows} {nonPortable} {
+} -result {.raise1}
+test raise-6.2 {raise/lower toplevel windows} -constraints {
+ nonPortable
+} -body {
raise_makeToplevels
update
raise .raise2
winfo containing [winfo rootx .raise1] [winfo rooty .raise1]
-} .raise2
-test raise-6.3 {raise/lower toplevel windows} {nonPortable} {
+} -result {.raise2}
+test raise-6.3 {raise/lower toplevel windows} -constraints {
+ nonPortable
+} -body {
raise_makeToplevels
update
raise .raise3
@@ -214,8 +239,10 @@ test raise-6.3 {raise/lower toplevel windows} {nonPortable} {
after 500
list $result [winfo containing [winfo rootx .raise1] \
[winfo rooty .raise1]]
-} {.raise2 .raise1}
-test raise-6.4 {raise/lower toplevel windows} {nonPortable} {
+} -result {.raise2 .raise1}
+test raise-6.4 {raise/lower toplevel windows} -constraints {
+ nonPortable
+} -body {
raise_makeToplevels
update
raise .raise2
@@ -230,14 +257,18 @@ test raise-6.4 {raise/lower toplevel windows} {nonPortable} {
after 500
list $result [winfo containing [winfo rootx .raise2] \
[winfo rooty .raise2]]
-} {.raise1 .raise3}
-test raise-6.5 {raise/lower toplevel windows} {nonPortable} {
+} -result {.raise1 .raise3}
+test raise-6.5 {raise/lower toplevel windows} -constraints {
+ nonPortable
+} -body {
raise_makeToplevels
raise .raise1
set time [lindex [time {raise .raise1}] 0]
expr {$time < 2000000}
-} 1
-test raise-6.6 {raise/lower toplevel windows} {nonPortable} {
+} -result 1
+test raise-6.6 {raise/lower toplevel windows} -constraints {
+ nonPortable
+} -body {
raise_makeToplevels
update
raise .raise2
@@ -253,35 +284,37 @@ test raise-6.6 {raise/lower toplevel windows} {nonPortable} {
after 500
list $result [winfo containing [winfo rootx .raise2] \
[winfo rooty .raise2]]
-} {.raise1 .raise3}
+} -result {.raise1 .raise3}
+
-test raise-7.1 {errors in raise/lower commands} {
- list [catch {raise} msg] $msg
-} {1 {wrong # args: should be "raise window ?aboveThis?"}}
-test raise-7.2 {errors in raise/lower commands} {
- list [catch {raise a b c} msg] $msg
-} {1 {wrong # args: should be "raise window ?aboveThis?"}}
-test raise-7.3 {errors in raise/lower commands} {
- list [catch {raise badName} msg] $msg
-} {1 {bad window path name "badName"}}
-test raise-7.4 {errors in raise/lower commands} {
- list [catch {raise . badName2} msg] $msg
-} {1 {bad window path name "badName2"}}
-test raise-7.5 {errors in raise/lower commands} {
- list [catch {lower} msg] $msg
-} {1 {wrong # args: should be "lower window ?belowThis?"}}
-test raise-7.6 {errors in raise/lower commands} {
- list [catch {lower a b c} msg] $msg
-} {1 {wrong # args: should be "lower window ?belowThis?"}}
-test raise-7.7 {errors in raise/lower commands} {
- list [catch {lower badName3} msg] $msg
-} {1 {bad window path name "badName3"}}
-test raise-7.8 {errors in raise/lower commands} {
- list [catch {lower . badName4} msg] $msg
-} {1 {bad window path name "badName4"}}
+test raise-7.1 {errors in raise/lower commands} -body {
+ raise
+} -returnCodes error -result {wrong # args: should be "raise window ?aboveThis?"}
+test raise-7.2 {errors in raise/lower commands} -body {
+ raise a b c
+} -returnCodes error -result {wrong # args: should be "raise window ?aboveThis?"}
+test raise-7.3 {errors in raise/lower commands} -body {
+ raise badName
+} -returnCodes error -result {bad window path name "badName"}
+test raise-7.4 {errors in raise/lower commands} -body {
+ raise . badName2
+} -returnCodes error -result {bad window path name "badName2"}
+test raise-7.5 {errors in raise/lower commands} -body {
+ lower
+} -returnCodes error -result {wrong # args: should be "lower window ?belowThis?"}
+test raise-7.6 {errors in raise/lower commands} -body {
+ lower a b c
+} -returnCodes error -result {wrong # args: should be "lower window ?belowThis?"}
+test raise-7.7 {errors in raise/lower commands} -body {
+ lower badName3
+} -returnCodes error -result {bad window path name "badName3"}
+test raise-7.8 {errors in raise/lower commands} -body {
+ lower . badName4
+} -returnCodes error -result {bad window path name "badName4"}
deleteWindows
# cleanup
cleanupTests
return
+
diff --git a/tests/safe.test b/tests/safe.test
index 3e9f716..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 657f668..13ccb4d 100644
--- a/tests/scale.test
+++ b/tests/scale.test
@@ -6,7 +6,8 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
@@ -17,220 +18,497 @@ option add *Scale.borderWidth 2
option add *Scale.highlightThickness 2
option add *Scale.font {Helvetica -12 bold}
+# Widget used in 1.* tests
scale .s -from 100 -to 300
pack .s
update
-set i 1
-foreach test {
- {-activebackground #ff0000 #ff0000 non-existent
- {unknown color name "non-existent"}}
- {-background #ff0000 #ff0000 non-existent
- {unknown color name "non-existent"}}
- {-bd 4 4 badValue {bad screen distance "badValue"}}
- {-bigincrement 12.5 12.5 badValue
- {expected floating-point number but got "badValue"}}
- {-bg #ff0000 #ff0000 non-existent
- {unknown color name "non-existent"}}
- {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
- {-command "set x" {set x} {} {}}
- {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
- {-digits 5 5 badValue {expected integer but got "badValue"}}
- {-fg #00ff00 #00ff00 badValue {unknown color name "badValue"}}
- {-font fixed fixed {} {font "" doesn't exist}}
- {-foreground green green badValue {unknown color name "badValue"}}
- {-from -15.0 -15.0 badValue
- {expected floating-point number but got "badValue"}}
- {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}}
- {-highlightcolor #123456 #123456 non-existent
- {unknown color name "non-existent"}}
- {-highlightthickness 2 2 badValue {bad screen distance "badValue"}}
- {-label "Some text" {Some text} {} {}}
- {-length 130 130 badValue {bad screen distance "badValue"}}
- {-orient horizontal horizontal badValue
- {bad orient "badValue": must be horizontal or vertical}}
- {-orient horizontal horizontal {} {}}
- {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
- {-repeatdelay 14 14 bogus {expected integer but got "bogus"}}
- {-repeatinterval 14 14 bogus {expected integer but got "bogus"}}
- {-resolution 2.0 2.0 badValue
- {expected floating-point number but got "badValue"}}
- {-showvalue 0 0 badValue {expected boolean value but got "badValue"}}
- {-sliderlength 86 86 badValue {bad screen distance "badValue"}}
- {-sliderrelief raised raised badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
- {-state d disabled badValue
- {bad state "badValue": must be active, disabled, or normal}}
- {-state n normal {} {}}
- {-takefocus "any string" "any string" {} {}}
- {-tickinterval 4.3 4.0 badValue
- {expected floating-point number but got "badValue"}}
- {-to 14.9 15.0 badValue
- {expected floating-point number but got "badValue"}}
- {-troughcolor #ff0000 #ff0000 non-existent
- {unknown color name "non-existent"}}
- {-variable x x {} {}}
- {-width 32 32 badValue {bad screen distance "badValue"}}
-} {
- set name [lindex $test 0]
- test scale-1.$i {configuration options} {
- .s configure $name [lindex $test 1]
- lindex [.s configure $name] 4
- } [lindex $test 2]
- incr i
- if {[lindex $test 3] ne ""} {
- test scale-1.$i {configuration options} {
- list [catch {.s configure $name [lindex $test 3]} msg] $msg
- } [list 1 [lindex $test 4]]
- }
- .s configure $name [lindex [.s configure $name] 3]
- incr i
-}
+
+test scale-1.1 {configuration options} -body {
+ .s configure -activebackground #ff0000
+ .s cget -activebackground
+} -cleanup {
+ .s configure -activebackground [lindex [.s configure -activebackground] 3]
+} -result {#ff0000}
+test scale-1.2 {configuration options} -body {
+ .s configure -activebackground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test scale-1.3 {configuration options} -body {
+ .s configure -background #ff0000
+ .s cget -background
+} -cleanup {
+ .s configure -background [lindex [.s configure -background] 3]
+} -result {#ff0000}
+test scale-1.4 {configuration options} -body {
+ .s configure -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test scale-1.5 {configuration options} -body {
+ .s configure -bd 4
+ .s cget -bd
+} -cleanup {
+ .s configure -bd [lindex [.s configure -bd] 3]
+} -result {4}
+test scale-1.6 {configuration options} -body {
+ .s configure -bd badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test scale-1.7 {configuration options} -body {
+ .s configure -bigincrement 12.5
+ .s cget -bigincrement
+} -cleanup {
+ .s configure -bigincrement [lindex [.s configure -bigincrement] 3]
+} -result {12.5}
+test scale-1.8 {configuration options} -body {
+ .s configure -bigincrement badValue
+} -returnCodes error -result {expected floating-point number but got "badValue"}
+test scale-1.9 {configuration options} -body {
+ .s configure -bg #ff0000
+ .s cget -bg
+} -cleanup {
+ .s configure -bg [lindex [.s configure -bg] 3]
+} -result {#ff0000}
+test scale-1.10 {configuration options} -body {
+ .s configure -bg non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test scale-1.11 {configuration options} -body {
+ .s configure -borderwidth 1.3
+ .s cget -borderwidth
+} -cleanup {
+ .s configure -borderwidth [lindex [.s configure -borderwidth] 3]
+} -result {1}
+test scale-1.12 {configuration options} -body {
+ .s configure -borderwidth badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test scale-1.13 {configuration options} -body {
+ .s configure -command {set x}
+ .s cget -command
+} -cleanup {
+ .s configure -command [lindex [.s configure -command] 3]
+} -result {set x}
+test scale-1.15 {configuration options} -body {
+ .s configure -cursor arrow
+ .s cget -cursor
+} -cleanup {
+ .s configure -cursor [lindex [.s configure -cursor] 3]
+} -result {arrow}
+test scale-1.16 {configuration options} -body {
+ .s configure -cursor badValue
+} -returnCodes error -result {bad cursor spec "badValue"}
+test scale-1.17 {configuration options} -body {
+ .s configure -digits 5
+ .s cget -digits
+} -cleanup {
+ .s configure -digits [lindex [.s configure -digits] 3]
+} -result {5}
+test scale-1.18 {configuration options} -body {
+ .s configure -digits badValue
+} -returnCodes error -result {expected integer but got "badValue"}
+test scale-1.19 {configuration options} -body {
+ .s configure -fg #00ff00
+ .s cget -fg
+} -cleanup {
+ .s configure -fg [lindex [.s configure -fg] 3]
+} -result {#00ff00}
+test scale-1.20 {configuration options} -body {
+ .s configure -fg badValue
+} -returnCodes error -result {unknown color name "badValue"}
+test scale-1.21 {configuration options} -body {
+ .s configure -font fixed
+ .s cget -font
+} -cleanup {
+ .s configure -font [lindex [.s configure -font] 3]
+} -result {fixed}
+test scale-1.23 {configuration options} -body {
+ .s configure -foreground green
+ .s cget -foreground
+} -cleanup {
+ .s configure -foreground [lindex [.s configure -foreground] 3]
+} -result {green}
+test scale-1.24 {configuration options} -body {
+ .s configure -foreground badValue
+} -returnCodes error -result {unknown color name "badValue"}
+test scale-1.25 {configuration options} -body {
+ .s configure -from -15.0
+ .s cget -from
+} -cleanup {
+ .s configure -from [lindex [.s configure -from] 3]
+} -result {-15.0}
+test scale-1.26 {configuration options} -body {
+ .s configure -from badValue
+} -returnCodes error -result {expected floating-point number but got "badValue"}
+test scale-1.27 {configuration options} -body {
+ .s configure -highlightbackground #112233
+ .s cget -highlightbackground
+} -cleanup {
+ .s configure -highlightbackground [lindex [.s configure -highlightbackground] 3]
+} -result {#112233}
+test scale-1.28 {configuration options} -body {
+ .s configure -highlightbackground ugly
+} -returnCodes error -result {unknown color name "ugly"}
+test scale-1.29 {configuration options} -body {
+ .s configure -highlightcolor #123456
+ .s cget -highlightcolor
+} -cleanup {
+ .s configure -highlightcolor [lindex [.s configure -highlightcolor] 3]
+} -result {#123456}
+test scale-1.30 {configuration options} -body {
+ .s configure -highlightcolor non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test scale-1.31 {configuration options} -body {
+ .s configure -highlightthickness 2
+ .s cget -highlightthickness
+} -cleanup {
+ .s configure -highlightthickness [lindex [.s configure -highlightthickness] 3]
+} -result {2}
+test scale-1.32 {configuration options} -body {
+ .s configure -highlightthickness badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test scale-1.33 {configuration options} -body {
+ .s configure -label {Some text}
+ .s cget -label
+} -cleanup {
+ .s configure -label [lindex [.s configure -label] 3]
+} -result {Some text}
+test scale-1.35 {configuration options} -body {
+ .s configure -length 130
+ .s cget -length
+} -cleanup {
+ .s configure -length [lindex [.s configure -length] 3]
+} -result {130}
+test scale-1.36 {configuration options} -body {
+ .s configure -length badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test scale-1.37 {configuration options} -body {
+ .s configure -orient horizontal
+ .s cget -orient
+} -cleanup {
+ .s configure -orient [lindex [.s configure -orient] 3]
+} -result {horizontal}
+test scale-1.38 {configuration options} -body {
+ .s configure -orient badValue
+} -returnCodes error -result {bad orient "badValue": must be horizontal or vertical}
+test scale-1.39 {configuration options} -body {
+ .s configure -orient horizontal
+ .s cget -orient
+} -cleanup {
+ .s configure -orient [lindex [.s configure -orient] 3]
+} -result {horizontal}
+test scale-1.41 {configuration options} -body {
+ .s configure -relief ridge
+ .s cget -relief
+} -cleanup {
+ .s configure -relief [lindex [.s configure -relief] 3]
+} -result {ridge}
+test scale-1.42 {configuration options} -body {
+ .s configure -relief badValue
+} -returnCodes error -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}
+test scale-1.43 {configuration options} -body {
+ .s configure -repeatdelay 14
+ .s cget -repeatdelay
+} -cleanup {
+ .s configure -repeatdelay [lindex [.s configure -repeatdelay] 3]
+} -result {14}
+test scale-1.44 {configuration options} -body {
+ .s configure -repeatdelay bogus
+} -returnCodes error -result {expected integer but got "bogus"}
+test scale-1.45 {configuration options} -body {
+ .s configure -repeatinterval 14
+ .s cget -repeatinterval
+} -cleanup {
+ .s configure -repeatinterval [lindex [.s configure -repeatinterval] 3]
+} -result {14}
+test scale-1.46 {configuration options} -body {
+ .s configure -repeatinterval bogus
+} -returnCodes error -result {expected integer but got "bogus"}
+test scale-1.47 {configuration options} -body {
+ .s configure -resolution 2.0
+ .s cget -resolution
+} -cleanup {
+ .s configure -resolution [lindex [.s configure -resolution] 3]
+} -result {2.0}
+test scale-1.48 {configuration options} -body {
+ .s configure -resolution badValue
+} -returnCodes error -result {expected floating-point number but got "badValue"}
+test scale-1.49 {configuration options} -body {
+ .s configure -showvalue 0
+ .s cget -showvalue
+} -cleanup {
+ .s configure -showvalue [lindex [.s configure -showvalue] 3]
+} -result {0}
+test scale-1.50 {configuration options} -body {
+ .s configure -showvalue badValue
+} -returnCodes error -result {expected boolean value but got "badValue"}
+test scale-1.51 {configuration options} -body {
+ .s configure -sliderlength 86
+ .s cget -sliderlength
+} -cleanup {
+ .s configure -sliderlength [lindex [.s configure -sliderlength] 3]
+} -result {86}
+test scale-1.52 {configuration options} -body {
+ .s configure -sliderlength badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test scale-1.53 {configuration options} -body {
+ .s configure -sliderrelief raised
+ .s cget -sliderrelief
+} -cleanup {
+ .s configure -sliderrelief [lindex [.s configure -sliderrelief] 3]
+} -result {raised}
+test scale-1.54 {configuration options} -body {
+ .s configure -sliderrelief badValue
+} -returnCodes error -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}
+test scale-1.55 {configuration options} -body {
+ .s configure -state d
+ .s cget -state
+} -cleanup {
+ .s configure -state [lindex [.s configure -state] 3]
+} -result {disabled}
+test scale-1.56 {configuration options} -body {
+ .s configure -state badValue
+} -returnCodes error -result {bad state "badValue": must be active, disabled, or normal}
+test scale-1.57 {configuration options} -body {
+ .s configure -state n
+ .s cget -state
+} -cleanup {
+ .s configure -state [lindex [.s configure -state] 3]
+} -result {normal}
+test scale-1.59 {configuration options} -body {
+ .s configure -takefocus {any string}
+ .s cget -takefocus
+} -cleanup {
+ .s configure -takefocus [lindex [.s configure -takefocus] 3]
+} -result {any string}
+test scale-1.61 {configuration options} -body {
+ .s configure -tickinterval 4.3
+ .s cget -tickinterval
+} -cleanup {
+ .s configure -tickinterval [lindex [.s configure -tickinterval] 3]
+} -result {4.0}
+test scale-1.62 {configuration options} -body {
+ .s configure -tickinterval badValue
+} -returnCodes error -result {expected floating-point number but got "badValue"}
+test scale-1.63 {configuration options} -body {
+ .s configure -to 14.9
+ .s cget -to
+} -cleanup {
+ .s configure -to [lindex [.s configure -to] 3]
+} -result {15.0}
+test scale-1.64 {configuration options} -body {
+ .s configure -to badValue
+} -returnCodes error -result {expected floating-point number but got "badValue"}
+test scale-1.65 {configuration options} -body {
+ .s configure -troughcolor #ff0000
+ .s cget -troughcolor
+} -cleanup {
+ .s configure -troughcolor [lindex [.s configure -troughcolor] 3]
+} -result {#ff0000}
+test scale-1.66 {configuration options} -body {
+ .s configure -troughcolor non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test scale-1.67 {configuration options} -body {
+ .s configure -variable x
+ .s cget -variable
+} -cleanup {
+ .s configure -variable [lindex [.s configure -variable] 3]
+} -result {x}
+test scale-1.69 {configuration options} -body {
+ .s configure -width 32
+ .s cget -width
+} -cleanup {
+ .s configure -width [lindex [.s configure -width] 3]
+} -result {32}
+test scale-1.70 {configuration options} -body {
+ .s configure -width badValue
+} -returnCodes error -result {bad screen distance "badValue"}
destroy .s
-test scale-2.1 {Tk_ScaleCmd procedure} {
- list [catch {scale} msg] $msg
-} {1 {wrong # args: should be "scale pathName ?options?"}}
-test scale-2.2 {Tk_ScaleCmd procedure} {
- list [catch {scale foo} msg] $msg [winfo child .]
-} {1 {bad window path name "foo"} {}}
-test scale-2.3 {Tk_ScaleCmd procedure} {
- list [catch {scale .s -gorp dumb} msg] $msg [winfo child .]
-} {1 {unknown option "-gorp"} {}}
+test scale-2.1 {Tk_ScaleCmd procedure} -body {
+ scale
+} -returnCodes error -result {wrong # args: should be "scale pathName ?-option value ...?"}
+test scale-2.2 {Tk_ScaleCmd procedure} -body {
+ scale foo
+} -returnCodes error -result {bad window path name "foo"}
+test scale-2.3 {Tk_ScaleCmd procedure} -body {
+ catch {scale foo}
+ winfo child .
+} -result {}
+test scale-2.4 {Tk_ScaleCmd procedure} -body {
+ scale .s -gorp dumb
+} -returnCodes error -result {unknown option "-gorp"}
+test scale-2.5 {Tk_ScaleCmd procedure} -body {
+ catch {scale .s -gorp dumb}
+ winfo child .
+} -result {}
+
+
+# Widget used in 3.* tests
+destroy .s
scale .s -from 100 -to 200
pack .s
update idletasks
-test scale-3.1 {ScaleWidgetCmd procedure} {
- list [catch {.s} msg] $msg
-} {1 {wrong # args: should be ".s option ?arg arg ...?"}}
-test scale-3.2 {ScaleWidgetCmd procedure, cget option} {
- list [catch {.s cget} msg] $msg
-} {1 {wrong # args: should be ".s cget option"}}
-test scale-3.3 {ScaleWidgetCmd procedure, cget option} {
- list [catch {.s cget a b} msg] $msg
-} {1 {wrong # args: should be ".s cget option"}}
-test scale-3.4 {ScaleWidgetCmd procedure, cget option} {
- list [catch {.s cget -gorp} msg] $msg
-} {1 {unknown option "-gorp"}}
-test scale-3.5 {ScaleWidgetCmd procedure, cget option} {
+test scale-3.1 {ScaleWidgetCmd procedure} -body {
+ .s
+} -returnCodes error -result {wrong # args: should be ".s option ?arg ...?"}
+test scale-3.2 {ScaleWidgetCmd procedure, cget option} -body {
+ .s cget
+} -returnCodes error -result {wrong # args: should be ".s cget option"}
+test scale-3.3 {ScaleWidgetCmd procedure, cget option} -body {
+ .s cget a b
+} -returnCodes error -result {wrong # args: should be ".s cget option"}
+test scale-3.4 {ScaleWidgetCmd procedure, cget option} -body {
+ .s cget -gorp
+} -returnCodes error -result {unknown option "-gorp"}
+test scale-3.5 {ScaleWidgetCmd procedure, cget option} -body {
+ .s configure -highlightthickness 2
.s cget -highlightthickness
-} {2}
-test scale-3.6 {ScaleWidgetCmd procedure, configure option} {
+} -result {2}
+test scale-3.6 {ScaleWidgetCmd procedure, configure option} -body {
list [llength [.s configure]] [lindex [.s configure] 6]
-} {33 {-command command Command {} {}}}
-test scale-3.7 {ScaleWidgetCmd procedure, configure option} {
- list [catch {.s configure -foo} msg] $msg
-} {1 {unknown option "-foo"}}
-test scale-3.8 {ScaleWidgetCmd procedure, configure option} {
- list [catch {.s configure -borderwidth 2 -bg} msg] $msg
-} {1 {value for "-bg" missing}}
-test scale-3.9 {ScaleWidgetCmd procedure, coords option} {
- list [catch {.s coords a b} msg] $msg
-} {1 {wrong # args: should be ".s coords ?value?"}}
-test scale-3.10 {ScaleWidgetCmd procedure, coords option} {
- list [catch {.s coords bad} msg] $msg
-} {1 {expected floating-point number but got "bad"}}
-test scale-3.11 {ScaleWidgetCmd procedure} {fonts} {
+} -result {33 {-command command Command {} {}}}
+test scale-3.7 {ScaleWidgetCmd procedure, configure option} -body {
+ .s configure -foo
+} -returnCodes error -result {unknown option "-foo"}
+test scale-3.8 {ScaleWidgetCmd procedure, configure option} -body {
+ .s configure -borderwidth 2 -bg
+} -returnCodes error -result {value for "-bg" missing}
+test scale-3.9 {ScaleWidgetCmd procedure, coords option} -body {
+ .s coords a b
+} -returnCodes error -result {wrong # args: should be ".s coords ?value?"}
+test scale-3.10 {ScaleWidgetCmd procedure, coords option} -body {
+ .s coords bad
+} -returnCodes error -result {expected floating-point number but got "bad"}
+test scale-3.11 {ScaleWidgetCmd procedure} -constraints {
+ fonts
+} -body {
+ .s configure -from 100 -to 200
+ update idletasks
.s set 120
.s coords
-} {38 34}
-test scale-3.12 {ScaleWidgetCmd procedure, coords option} {fonts} {
- .s configure -orient horizontal
- update
+} -result {38 34}
+test scale-3.12 {ScaleWidgetCmd procedure, coords option} -constraints {
+ fonts
+} -body {
+ .s configure -from 100 -to 200 -orient horizontal
+ update idletasks
.s set 120
.s coords
-} {34 31}
-.s configure -orient vertical
-update
-test scale-3.13 {ScaleWidgetCmd procedure, get option} {
- list [catch {.s get a} msg] $msg
-} {1 {wrong # args: should be ".s get ?x y?"}}
-test scale-3.14 {ScaleWidgetCmd procedure, get option} {
- list [catch {.s get a b c} msg] $msg
-} {1 {wrong # args: should be ".s get ?x y?"}}
-test scale-3.15 {ScaleWidgetCmd procedure, get option} {
- list [catch {.s get a 11} msg] $msg
-} {1 {expected integer but got "a"}}
-test scale-3.16 {ScaleWidgetCmd procedure, get option} {
- list [catch {.s get 12 b} msg] $msg
-} {1 {expected integer but got "b"}}
-test scale-3.17 {ScaleWidgetCmd procedure, get option} {
+} -result {34 31}
+test scale-3.13 {ScaleWidgetCmd procedure, get option} -body {
+ .s configure -orient vertical
+ update
+ .s get a
+} -returnCodes error -result {wrong # args: should be ".s get ?x y?"}
+test scale-3.14 {ScaleWidgetCmd procedure, get option} -body {
+ .s configure -orient vertical
+ update
+ .s get a b c
+} -returnCodes error -result {wrong # args: should be ".s get ?x y?"}
+test scale-3.15 {ScaleWidgetCmd procedure, get option} -body {
+ .s configure -orient vertical
+ update
+ .s get a 11
+} -returnCodes error -result {expected integer but got "a"}
+test scale-3.16 {ScaleWidgetCmd procedure, get option} -body {
+ .s configure -orient vertical
+ update
+ .s get 12 b
+} -returnCodes error -result {expected integer but got "b"}
+test scale-3.17 {ScaleWidgetCmd procedure, get option} -body {
+ .s configure -orient vertical
+ update
.s set 133
.s get
-} 133
-test scale-3.18 {ScaleWidgetCmd procedure, get option} {
- .s configure -resolution 0.5
+} -result 133
+test scale-3.18 {ScaleWidgetCmd procedure, get option} -body {
+ .s configure -orient vertical -resolution 0.5
+ update
.s set 150
.s get 37 34
-} 119.5
+} -result {119.5}
.s configure -resolution 1
-test scale-3.19 {ScaleWidgetCmd procedure, identify option} {
- list [catch {.s identify} msg] $msg
-} {1 {wrong # args: should be ".s identify x y"}}
-test scale-3.20 {ScaleWidgetCmd procedure, identify option} {
- list [catch {.s identify 1 2 3} msg] $msg
-} {1 {wrong # args: should be ".s identify x y"}}
-test scale-3.21 {ScaleWidgetCmd procedure, identify option} {
- list [catch {.s identify boo 16} msg] $msg
-} {1 {expected integer but got "boo"}}
-test scale-3.22 {ScaleWidgetCmd procedure, identify option} {
- list [catch {.s identify 17 bad} msg] $msg
-} {1 {expected integer but got "bad"}}
-test scale-3.23 {ScaleWidgetCmd procedure, identify option} {fonts} {
+test scale-3.19 {ScaleWidgetCmd procedure, identify option} -body {
+ .s identify
+} -returnCodes error -result {wrong # args: should be ".s identify x y"}
+test scale-3.20 {ScaleWidgetCmd procedure, identify option} -body {
+ .s identify 1 2 3
+} -returnCodes error -result {wrong # args: should be ".s identify x y"}
+test scale-3.21 {ScaleWidgetCmd procedure, identify option} -body {
+ .s identify boo 16
+} -returnCodes error -result {expected integer but got "boo"}
+test scale-3.22 {ScaleWidgetCmd procedure, identify option} -body {
+ .s identify 17 bad
+} -returnCodes error -result {expected integer but got "bad"}
+test scale-3.23 {ScaleWidgetCmd procedure, identify option} -constraints {
+ fonts
+} -body {
+ .s configure -from 100 -to 200 -orient vertical -resolution 1
+ update
.s set 120
list [.s identify 35 10] [.s identify 35 30] [.s identify 35 80] [.s identify 5 80]
-} {trough1 slider trough2 {}}
-test scale-3.24 {ScaleWidgetCmd procedure, set option} {
- list [catch {.s set} msg] $msg
-} {1 {wrong # args: should be ".s set value"}}
-test scale-3.25 {ScaleWidgetCmd procedure, set option} {
- list [catch {.s set a b} msg] $msg
-} {1 {wrong # args: should be ".s set value"}}
-test scale-3.26 {ScaleWidgetCmd procedure, set option} {
- list [catch {.s set bad} msg] $msg
-} {1 {expected floating-point number but got "bad"}}
-test scale-3.27 {ScaleWidgetCmd procedure, set option} {
+} -result {trough1 slider trough2 {}}
+test scale-3.24 {ScaleWidgetCmd procedure, set option} -body {
+ .s set
+} -returnCodes error -result {wrong # args: should be ".s set value"}
+test scale-3.25 {ScaleWidgetCmd procedure, set option} -body {
+ .s set a b
+} -returnCodes error -result {wrong # args: should be ".s set value"}
+test scale-3.26 {ScaleWidgetCmd procedure, set option} -body {
+ .s set bad
+} -returnCodes error -result {expected floating-point number but got "bad"}
+test scale-3.27 {ScaleWidgetCmd procedure, set option} -body {
+ .s configure -from 100 -to 200 -orient vertical -resolution 0.5
+ update
.s set 142
-} {}
-test scale-3.28 {ScaleWidgetCmd procedure, set option} {
+} -result {}
+test scale-3.28 {ScaleWidgetCmd procedure, set option} -body {
+ .s configure -from 100 -to 200 -orient vertical -resolution 1
+ update
.s set 118
.s configure -state disabled
.s set 181
.s configure -state normal
.s get
-} {118}
-test scale-3.29 {ScaleWidgetCmd procedure} {
- list [catch {.s dumb} msg] $msg
-} {1 {bad option "dumb": must be cget, configure, coords, get, identify, or set}}
-test scale-3.30 {ScaleWidgetCmd procedure} {
- list [catch {.s c} msg] $msg
-} {1 {ambiguous option "c": must be cget, configure, coords, get, identify, or set}}
-test scale-3.31 {ScaleWidgetCmd procedure} {
- list [catch {.s co} msg] $msg
-} {1 {ambiguous option "co": must be cget, configure, coords, get, identify, or set}}
-test scale-3.32 {ScaleWidgetCmd procedure, Tk_Preserve} {
+} -result {118}
+test scale-3.29 {ScaleWidgetCmd procedure} -body {
+ .s dumb
+} -returnCodes error -result {bad option "dumb": must be cget, configure, coords, get, identify, or set}
+test scale-3.30 {ScaleWidgetCmd procedure} -body {
+ .s c
+} -returnCodes error -result {ambiguous option "c": must be cget, configure, coords, get, identify, or set}
+test scale-3.31 {ScaleWidgetCmd procedure} -body {
+ .s co
+} -returnCodes error -result {ambiguous option "co": must be cget, configure, coords, get, identify, or set}
+destroy .s
+
+test scale-3.32 {ScaleWidgetCmd procedure, Tk_Preserve} -setup {
+ destroy .s
+} -body {
proc kill args {
- destroy .s
+ destroy .s
}
- catch {destroy .s}
scale .s -variable x -from 0 -to 100 -orient horizontal
pack .s
update
.s configure -command kill
.s set 55
-} {}
+} -cleanup {
+ destroy .s
+} -result {}
+
-test scale-4.1 {DestroyScale procedure} {
- catch {destroy .s}
+test scale-4.1 {DestroyScale procedure} -setup {
+ deleteWindows
+} -body {
set x 50
scale .s -variable x -from 0 -to 100 -orient horizontal
pack .s
update
destroy .s
list [catch {set x foo} msg] $msg $x
-} {0 foo foo}
+} -result {0 foo foo}
+
-test scale-5.1 {ConfigureScale procedure} {
- catch {destroy .s}
+test scale-5.1 {ConfigureScale procedure} -setup {
+ deleteWindows
+} -body {
set x 66
set y 77
scale .s -variable x -from 0 -to 100
@@ -238,14 +516,20 @@ test scale-5.1 {ConfigureScale procedure} {
update
.s configure -variable y
list [catch {set x foo} msg] $msg $x [.s get]
-} {0 foo foo 77}
-test scale-5.2 {ConfigureScale procedure} {
- catch {destroy .s}
+} -cleanup {
+ deleteWindows
+} -result {0 foo foo 77}
+test scale-5.2 {ConfigureScale procedure} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 100
- list [catch {.s configure -foo bar} msg] $msg
-} {1 {unknown option "-foo"}}
-test scale-5.3 {ConfigureScale procedure} {
- catch {destroy .s}
+ .s configure -foo bar
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {unknown option "-foo"}
+test scale-5.3 {ConfigureScale procedure} -setup {
+ deleteWindows
+} -body {
catch {unset x}
scale .s -from 0 -to 100 -variable x
set result $x
@@ -255,349 +539,475 @@ test scale-5.3 {ConfigureScale procedure} {
.s set 3
lappend result $x
unset x
- lappend result [catch {set x} msg] $msg
-} {0 0 92 3 0 3}
-test scale-5.4 {ConfigureScale procedure} {
- catch {destroy .s}
+ lappend result [set x]
+} -cleanup {
+ deleteWindows
+} -result {0 0 92 3 3}
+test scale-5.4 {ConfigureScale procedure} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 100
- list [catch {.s configure -orient dumb} msg] $msg
-} {1 {bad orient "dumb": must be horizontal or vertical}}
-test scale-5.5 {ConfigureScale procedure} {
- catch {destroy .s}
+ .s configure -orient dumb
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {bad orient "dumb": must be horizontal or vertical}
+test scale-5.5 {ConfigureScale procedure} -setup {
+ deleteWindows
+} -body {
scale .s -from 1.11 -to 1.89 -resolution .1 -tickinterval .76
list [format %.1f [.s cget -from]] [format %.1f [.s cget -to]] \
- [format %.1f [.s cget -tickinterval]]
-} {1.1 1.9 0.8}
-test scale-5.6 {ConfigureScale procedure} {
- catch {destroy .s}
+ [format %.1f [.s cget -tickinterval]]
+} -cleanup {
+ deleteWindows
+} -result {1.1 1.9 0.8}
+test scale-5.6 {ConfigureScale procedure} -setup {
+ deleteWindows
+} -body {
scale .s -from 1 -to 10 -tickinterval -2
pack .s
set result [lindex [.s configure -tickinterval] 4]
.s configure -from 10 -to 1 -tickinterval 2
lappend result [lindex [.s configure -tickinterval] 4]
-} {2.0 -2.0}
-test scale-5.7 {ConfigureScale procedure} {
- catch {destroy .s}
- list [catch {scale .s -from 0 -to 100 -state bogus} msg] $msg
-} {1 {bad state "bogus": must be active, disabled, or normal}}
+} -cleanup {
+ deleteWindows
+} -result {2.0 -2.0}
+test scale-5.7 {ConfigureScale procedure} -setup {
+ deleteWindows
+} -body {
+ scale .s -from 0 -to 100 -state bogus
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {bad state "bogus": must be active, disabled, or normal}
+
-catch {destroy .s}
+# Widget used in 6.* tests
+destroy .s
scale .s -orient horizontal -length 200
pack .s
-test scale-6.1 {ComputeFormat procedure} {
+test scale-6.1 {ComputeFormat procedure} -body {
.s configure -from 10 -to 100 -resolution 10
.s set 49.3
.s get
-} {50}
-test scale-6.2 {ComputeFormat procedure} {
+} -result {50}
+test scale-6.2 {ComputeFormat procedure} -body {
.s configure -from 100 -to 1000 -resolution 100
.s set 493
.s get
-} {500}
-test scale-6.3 {ComputeFormat procedure} {
+} -result {500}
+test scale-6.3 {ComputeFormat procedure} -body {
.s configure -from 1000 -to 10000 -resolution 1000
.s set 4930
.s get
-} {5000}
-test scale-6.4 {ComputeFormat procedure} {
+} -result {5000}
+test scale-6.4 {ComputeFormat procedure} -body {
.s configure -from 10000 -to 100000 -resolution 10000
.s set 49000
.s get
-} {50000}
-test scale-6.5 {ComputeFormat procedure} {
+} -result {50000}
+test scale-6.5 {ComputeFormat procedure} -body {
.s configure -from 100000 -to 1000000 -resolution 100000
.s set 493000
.s get
-} {500000}
-test scale-6.6 {ComputeFormat procedure} {nonPortable} {
+} -result {500000}
+test scale-6.6 {ComputeFormat procedure} -constraints {
+ nonPortable
+} -body {
# This test is non-portable because some platforms format the
# result as 5e+06.
-
.s configure -from 1000000 -to 10000000 -resolution 1000000
.s set 4930000
.s get
-} {5000000}
-test scale-6.7 {ComputeFormat procedure} {
+} -result {5000000}
+test scale-6.7 {ComputeFormat procedure} -body {
.s configure -from 1000000000 -to 10000000000 -resolution 1000000000
.s set 4930000000
expr {[.s get] == 5.0e+09}
-} 1
-test scale-6.8 {ComputeFormat procedure} {
+} -result 1
+test scale-6.8 {ComputeFormat procedure} -body {
.s configure -from .1 -to 1 -resolution .1
.s set .6
.s get
-} {0.6}
-test scale-6.9 {ComputeFormat procedure} {
+} -result {0.6}
+test scale-6.9 {ComputeFormat procedure} -body {
.s configure -from .01 -to .1 -resolution .01
.s set .06
.s get
-} {0.06}
-test scale-6.10 {ComputeFormat procedure} {
+} -result {0.06}
+test scale-6.10 {ComputeFormat procedure} -body {
.s configure -from .001 -to .01 -resolution .001
.s set .006
.s get
-} {0.006}
-test scale-6.11 {ComputeFormat procedure} {
+} -result {0.006}
+test scale-6.11 {ComputeFormat procedure} -body {
.s configure -from .0001 -to .001 -resolution .0001
.s set .0006
.s get
-} {0.0006}
-test scale-6.12 {ComputeFormat procedure} {
+} -result {0.0006}
+test scale-6.12 {ComputeFormat procedure} -body {
.s configure -from .00001 -to .0001 -resolution .00001
.s set .00006
.s get
-} {0.00006}
-test scale-6.13 {ComputeFormat procedure} {
+} -result {0.00006}
+test scale-6.13 {ComputeFormat procedure} -body {
.s configure -from .000001 -to .00001 -resolution .000001
.s set .000006
expr {[.s get] == 6.0e-06}
-} {1}
-test scale-6.14 {ComputeFormat procedure} {
+} -result {1}
+test scale-6.14 {ComputeFormat procedure} -body {
.s configure -to .00001 -from .0001 -resolution .00001
.s set .00006
.s get
-} {0.00006}
-test scale-6.15 {ComputeFormat procedure} {
+} -result {0.00006}
+test scale-6.15 {ComputeFormat procedure} -body {
.s configure -to .000001 -from .00001 -resolution .000001
.s set .000006
expr {[.s get] == 6.0e-06}
-} {1}
-test scale-6.16 {ComputeFormat procedure} {
+} -result {1}
+test scale-6.16 {ComputeFormat procedure} -body {
.s configure -from .00001 -to .0001 -resolution .00001 -digits 1
.s set .00006
expr {[.s get] == 6e-05}
-} {1}
-test scale-6.17 {ComputeFormat procedure} {
+} -result {1}
+test scale-6.17 {ComputeFormat procedure} -body {
.s configure -from 10000000 -to 100000000 -resolution 10000000 -digits 3
.s set 49300000
.s get
-} {50000000}
-test scale-6.18 {ComputeFormat procedure} {
+} -result {50000000}
+test scale-6.18 {ComputeFormat procedure} -body {
.s configure -length 200 -from 0 -to 10 -resolution 0 -digits 0
.s set .111111111
.s get
-} {0.11}
-test scale-6.19 {ComputeFormat procedure} {
+} -result {0.11}
+test scale-6.19 {ComputeFormat procedure} -body {
.s configure -length 200 -from 1000 -to 1002 -resolution 0 -digits 0
.s set 1001.23456789
.s get
-} {1001.23}
-test scale-6.20 {ComputeFormat procedure} {
+} -result {1001.23}
+test scale-6.20 {ComputeFormat procedure} -body {
.s configure -length 200 -from 1000 -to 1001.8 -resolution 0 -digits 0
.s set 1001.23456789
.s get
-} {1001.235}
+} -result {1001.235}
+destroy .s
-test scale-7.1 {ComputeScaleGeometry procedure} {nonPortable fonts} {
- catch {destroy .s}
+
+test scale-7.1 {ComputeScaleGeometry procedure} -constraints {
+ nonPortable fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 10 -label "Short" -orient vertical -length 5i
pack .s
update
list [winfo reqwidth .s] [winfo reqheight .s]
-} {88 458}
-test scale-7.2 {ComputeScaleGeometry procedure} {fonts} {
- catch {destroy .s}
+} -cleanup {
+ deleteWindows
+} -result {88 458}
+test scale-7.2 {ComputeScaleGeometry procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 1000 -label "Long string" -orient vertical -tick 200
pack .s
update
list [winfo reqwidth .s] [winfo reqheight .s]
-} {168 108}
-test scale-7.3 {ComputeScaleGeometry procedure} {fonts} {
- catch {destroy .s}
+} -cleanup {
+ deleteWindows
+} -result {168 108}
+test scale-7.3 {ComputeScaleGeometry procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 1000 -orient vertical -showvalue 0 -width 10 \
- -sliderlength 10
+ -sliderlength 10
pack .s
update
list [winfo reqwidth .s] [winfo reqheight .s]
-} {22 108}
-test scale-7.4 {ComputeScaleGeometry procedure} {fonts} {
- catch {destroy .s}
+} -cleanup {
+ deleteWindows
+} -result {22 108}
+test scale-7.4 {ComputeScaleGeometry procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 1000 -orient vertical -showvalue 0 -bd 5 \
- -relief sunken
+ -relief sunken
pack .s
update
list [winfo reqwidth .s] [winfo reqheight .s]
-} {39 114}
-test scale-7.5 {ComputeScaleGeometry procedure} {nonPortable fonts} {
- catch {destroy .s}
+} -cleanup {
+ deleteWindows
+} -result {39 114}
+test scale-7.5 {ComputeScaleGeometry procedure} -constraints {
+ nonPortable fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 10 -label "Short" -orient horizontal -length 5i
pack .s
update
list [winfo reqwidth .s] [winfo reqheight .s]
-} {458 61}
-test scale-7.6 {ComputeScaleGeometry procedure} {fonts} {
- catch {destroy .s}
+} -cleanup {
+ deleteWindows
+} -result {458 61}
+test scale-7.6 {ComputeScaleGeometry procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 1000 -label "Long string" -orient horizontal \
- -tick 500
+ -tick 500
pack .s
update
list [winfo reqwidth .s] [winfo reqheight .s]
-} {108 79}
-test scale-7.7 {ComputeScaleGeometry procedure} {fonts} {
- catch {destroy .s}
+} -cleanup {
+ deleteWindows
+} -result {108 79}
+test scale-7.7 {ComputeScaleGeometry procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 1000 -orient horizontal -showvalue 0
pack .s
update
list [winfo reqwidth .s] [winfo reqheight .s]
-} {108 27}
-test scale-7.8 {ComputeScaleGeometry procedure} {
- catch {destroy .s}
+} -cleanup {
+ deleteWindows
+} -result {108 27}
+test scale-7.8 {ComputeScaleGeometry procedure} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 1000 -orient horizontal -showvalue 0 -bd 5 \
- -relief raised -highlightthickness 2
+ -relief raised -highlightthickness 2
pack .s
update
list [winfo reqwidth .s] [winfo reqheight .s]
-} {114 39}
+} -cleanup {
+ deleteWindows
+} -result {114 39}
+
-test scale-8.1 {ScaleElement procedure} {fonts} {
- catch {destroy .s}
+test scale-8.1 {ScaleElement procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 100 -orient vertical -bd 1 -tick 20 -length 300
pack .s
.s set 30
update
list [.s identify 53 52] [.s identify 54 52] [.s identify 70 52] \
- [.s identify 71 52]
-} {{} trough1 trough1 {}}
-test scale-8.2 {ScaleElement procedure} {fonts} {
- catch {destroy .s}
+ [.s identify 71 52]
+} -cleanup {
+ deleteWindows
+} -result {{} trough1 trough1 {}}
+test scale-8.2 {ScaleElement procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 100 -orient vertical -bd 1 -tick 20 -length 300
pack .s
.s set 30
update
list [.s identify 60 2] [.s identify 60 3] [.s identify 60 302] \
- [.s identify 60 303]
-} {{} trough1 trough2 {}}
-test scale-8.3 {ScaleElement procedure} {fonts} {
- catch {destroy .s}
+ [.s identify 60 303]
+} -cleanup {
+ deleteWindows
+} -result {{} trough1 trough2 {}}
+test scale-8.3 {ScaleElement procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 100 -orient vertical -bd 1 -tick 20 -length 300
pack .s
.s set 30
update
list [.s identify 60 83] [.s identify 60 84] [.s identify 60 113] \
- [.s identify 60 114] \
-} {trough1 slider slider trough2}
-test scale-8.4 {ScaleElement procedure} {
- catch {destroy .s}
+ [.s identify 60 114] \
+} -cleanup {
+ deleteWindows
+} -result {trough1 slider slider trough2}
+test scale-8.4 {ScaleElement procedure} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 100 -orient vertical -bd 4 -width 10 \
- -highlightthickness 1 -length 300 -showvalue 0
+ -highlightthickness 1 -length 300 -showvalue 0
pack .s
.s set 30
update
list [.s identify 4 40] [.s identify 5 40] [.s identify 22 40] \
- [.s identify 23 40] \
-} {{} trough1 trough1 {}}
-test scale-8.5 {ScaleElement procedure} {fonts} {
- catch {destroy .s}
+ [.s identify 23 40] \
+} -cleanup {
+ deleteWindows
+} -result {{} trough1 trough1 {}}
+test scale-8.5 {ScaleElement procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 100 -orient horizontal -bd 1 \
- -highlightthickness 2 -tick 20 -sliderlength 20 \
- -length 200 -label Test
+ -highlightthickness 2 -tick 20 -sliderlength 20 \
+ -length 200 -label Test
pack .s
.s set 30
update
list [.s identify 150 36] [.s identify 150 37] [.s identify 150 53] \
- [.s identify 150 54]
-} {{} trough2 trough2 {}}
-test scale-8.6 {ScaleElement procedure} {fonts} {
- catch {destroy .s}
+ [.s identify 150 54]
+} -cleanup {
+ deleteWindows
+} -result {{} trough2 trough2 {}}
+test scale-8.6 {ScaleElement procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 100 -orient horizontal -bd 2 \
- -highlightthickness 1 -tick 20 -length 200
+ -highlightthickness 1 -tick 20 -length 200
pack .s
.s set 30
update
list [.s identify 150 20] [.s identify 150 21] [.s identify 150 39] \
- [.s identify 150 40]
-} {{} trough2 trough2 {}}
-test scale-8.7 {ScaleElement procedure} {
- catch {destroy .s}
+ [.s identify 150 40]
+} -cleanup {
+ deleteWindows
+} -result {{} trough2 trough2 {}}
+test scale-8.7 {ScaleElement procedure} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 100 -orient horizontal -bd 4 -highlightthickness 2 \
- -length 200 -width 10 -showvalue 0
+ -length 200 -width 10 -showvalue 0
pack .s
.s set 30
update
list [.s identify 30 5] [.s identify 30 6] [.s identify 30 23] \
- [.s identify 30 24]
-} {{} trough1 trough1 {}}
-test scale-8.8 {ScaleElement procedure} {
- catch {destroy .s}
+ [.s identify 30 24]
+} -cleanup {
+ deleteWindows
+} -result {{} trough1 trough1 {}}
+test scale-8.8 {ScaleElement procedure} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 100 -orient horizontal -bd 1 -highlightthickness 2 \
- -tick 20 -sliderlength 20 -length 200 -label Test -showvalue 0
+ -tick 20 -sliderlength 20 -length 200 -label Test -showvalue 0
pack .s
.s set 30
update
list [.s identify 2 28] [.s identify 3 28] [.s identify 202 28] \
- [.s identify 203 28]
-} {{} trough1 trough2 {}}
-test scale-8.9 {ScaleElement procedure} {
- catch {destroy .s}
+ [.s identify 203 28]
+} -cleanup {
+ deleteWindows
+} -result {{} trough1 trough2 {}}
+test scale-8.9 {ScaleElement procedure} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 100 -orient horizontal -bd 1 -highlightthickness 2 \
- -tick 20 -sliderlength 20 -length 200 -label Test -showvalue 0
+ -tick 20 -sliderlength 20 -length 200 -label Test -showvalue 0
pack .s
.s set 80
update
list [.s identify 145 28] [.s identify 146 28] [.s identify 165 28] \
- [.s identify 166 28]
-} {trough1 slider slider trough2}
+ [.s identify 166 28]
+} -cleanup {
+ deleteWindows
+} -result {trough1 slider slider trough2}
-catch {destroy .s}
-scale .s -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
-pack .s
-update
-test scale-9.1 {PixelToValue procedure} {
+
+#widget used in 9.* tests
+destroy .s
+pack [scale .s]
+test scale-9.1 {PixelToValue procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
+ update
.s get 46 0
-} 0
-test scale-9.2 {PixelToValue procedure} {
+} -result 0
+test scale-9.2 {PixelToValue procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
+ update
.s get -10 9
-} 0
-test scale-9.3 {PixelToValue procedure} {
+} -result 0
+test scale-9.3 {PixelToValue procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
+ update
.s get -10 12
-} 1
-test scale-9.4 {PixelToValue procedure} {
+} -result 1
+test scale-9.4 {PixelToValue procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
+ update
.s get -10 46
-} 35
-test scale-9.5 {PixelToValue procedure} {
+} -result 35
+test scale-9.5 {PixelToValue procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
+ update
.s get -10 110
-} 99
-test scale-9.6 {PixelToValue procedure} {
+} -result 99
+test scale-9.6 {PixelToValue procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
+ update
.s get -10 111
-} 100
-test scale-9.7 {PixelToValue procedure} {
+} -result 100
+test scale-9.7 {PixelToValue procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
+ update
.s get -10 112
-} 100
-test scale-9.8 {PixelToValue procedure} {
+} -result 100
+test scale-9.8 {PixelToValue procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
+ update
.s get -10 154
-} 100
-.s configure -orient horizontal
-update
-test scale-9.9 {PixelToValue procedure} {
+} -result 100
+test scale-9.9 {PixelToValue procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal
+ update
.s get 76 152
-} 65
+} -result 65
+destroy .s
+
-test scale-10.1 {ValueToPixel procedure} {fonts} {
- catch {destroy .s}
+test scale-10.1 {ValueToPixel procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 100 -sliderlength 20 -length 124 -bd 2 \
- -orient horizontal -label Test -tick 20
+ -orient horizontal -label Test -tick 20
pack .s
update
list [.s coords -10] [.s coords 40] [.s coords 1000]
-} {{16 47} {56 47} {116 47}}
-test scale-10.2 {ValueToPixel procedure} {fonts} {
- catch {destroy .s}
+} -cleanup {
+ deleteWindows
+} -result {{16 47} {56 47} {116 47}}
+test scale-10.2 {ValueToPixel procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 100 -to 0 -sliderlength 20 -length 122 -bd 1 \
- -orient vertical -label Test -tick 20
+ -orient vertical -label Test -tick 20
pack .s
update
list [.s coords -10] [.s coords 40] [.s coords 1000]
-} {{62 114} {62 74} {62 14}}
+} -cleanup {
+ deleteWindows
+} -result {{62 114} {62 74} {62 14}}
+
-test scale-11.1 {ScaleEventProc procedure} {
+test scale-11.1 {ScaleEventProc procedure} -setup {
+ deleteWindows
+} -body {
proc killScale value {
- global x
- if {$value > 30} {
- destroy .s1
- lappend x [winfo exists .s1] [info commands .s1]
- }
+ global x
+ if {$value > 30} {
+ destroy .s1
+ lappend x [winfo exists .s1] [info commands .s1]
+ }
}
- catch {destroy .s1}
set x initial
scale .s1 -from 0 -to 100 -command killScale
.s1 set 20
@@ -606,60 +1016,74 @@ test scale-11.1 {ScaleEventProc procedure} {
lappend x [winfo exists .s1]
.s1 set 40
update idletasks
+ return $x
+} -cleanup {
rename killScale {}
- set x
-} {initial 1 0 {}}
-test scale-11.2 {ScaleEventProc procedure} {
deleteWindows
+} -result {initial 1 0 {}}
+test scale-11.2 {ScaleEventProc procedure} -setup {
+ deleteWindows
+ set x {}
+} -body {
scale .s1 -bg #543210
rename .s1 .s2
- set x {}
lappend x [winfo children .]
lappend x [.s2 cget -bg]
destroy .s1
lappend x [info command .s*] [winfo children .]
-} {.s1 #543210 {} {}}
+} -cleanup {
+ deleteWindows
+} -result {.s1 #543210 {} {}}
-test scale-12.1 {ScaleCmdDeletedProc procedure} {
+test scale-12.1 {ScaleCmdDeletedProc procedure} -setup {
deleteWindows
+} -body {
scale .s1
rename .s1 {}
list [info command .s*] [winfo children .]
-} {{} {}}
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
-catch {destroy .s}
-scale .s -from 0 -to 100 -command {set x} -variable y
-pack .s
+
+# Widget used in 13.* tests
+destroy .s
+pack [scale .s]
update
-proc varTrace args {
- global traceInfo
- set traceInfo $args
-}
-test scale-13.1 {SetScaleValue procedure} {
+test scale-13.1 {SetScaleValue procedure} -body {
+ .s configure -from 0 -to 100 -command {set x} -variable y
+ update
set x xyzzy
.s set 44
set result [list $x $y]
update
lappend result $x $y
-} {xyzzy 44 44 44}
-test scale-13.2 {SetScaleValue procedure} {
+} -result {xyzzy 44 44 44}
+test scale-13.2 {SetScaleValue procedure} -body {
.s set -3
.s get
-} 0
-test scale-13.3 {SetScaleValue procedure} {
+} -result 0
+test scale-13.3 {SetScaleValue procedure} -body {
.s set 105
.s get
-} 100
+} -result 100
.s configure -from 100 -to 0
-test scale-13.4 {SetScaleValue procedure} {
+test scale-13.4 {SetScaleValue procedure} -body {
.s set -3
.s get
-} 0
-test scale-13.5 {SetScaleValue procedure} {
+} -result 0
+test scale-13.5 {SetScaleValue procedure} -body {
.s set 105
.s get
-} 100
-test scale-13.6 {SetScaleValue procedure} {
+} -result 100
+test scale-13.6 {SetScaleValue procedure} -body {
+ proc varTrace args {
+ global traceInfo
+ set traceInfo $args
+ }
+ .s configure -from 0 -to 100 -command {set x} -variable y
+ update
+
.s set 50
update
trace variable y w varTrace
@@ -668,127 +1092,201 @@ test scale-13.6 {SetScaleValue procedure} {
.s set 50
update
list $x $traceInfo
-} {untouched empty}
+} -result {untouched empty}
-catch {destroy .s}
-scale .s -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 -orient horizontal
-pack .s
-update
-.s configure -resolution 4.0
+
+# Widget used in 14.* tests
+destroy .s
+pack [scale .s]
update
-test scale-14.1 {RoundToResolution procedure} {
+test scale-14.1 {RoundToResolution procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 4.0
+ update
.s get 84 152
-} 72
-test scale-14.2 {RoundToResolution procedure} {
+} -result 72
+test scale-14.2 {RoundToResolution procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 4.0
+ update
.s get 86 152
-} 76
-.s configure -from 100 -to 0
-update
-test scale-14.3 {RoundToResolution procedure} {
+} -result 76
+
+test scale-14.3 {RoundToResolution procedure} -body {
+ .s configure -from 100 -to 0 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 4.0
+ update
.s get 84 152
-} 28
-test scale-14.4 {RoundToResolution procedure} {
+} -result 28
+test scale-14.4 {RoundToResolution procedure} -body {
+ .s configure -from 100 -to 0 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 4.0
+ update
.s get 86 152
-} 24
-.s configure -from -100 -to 0
-update
-test scale-14.5 {RoundToResolution procedure} {
+} -result 24
+
+test scale-14.5 {RoundToResolution procedure} -body {
+ .s configure -from -100 -to 0 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 4.0
+ update
.s get 84 152
-} -28
-test scale-14.6 {RoundToResolution procedure} {
+} -result {-28}
+test scale-14.6 {RoundToResolution procedure} -body {
+ .s configure -from -100 -to 0 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 4.0
+ update
.s get 86 152
-} -24
-.s configure -from 0 -to -100
-update
-test scale-14.7 {RoundToResolution procedure} {
+} -result {-24}
+
+test scale-14.7 {RoundToResolution procedure} -body {
+ .s configure -from 0 -to -100 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 4.0
+ update
.s get 84 152
-} -72
-test scale-14.8 {RoundToResolution procedure} {
+} -result {-72}
+test scale-14.8 {RoundToResolution procedure} -body {
+ .s configure -from 0 -to -100 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 4.0
+ update
.s get 86 152
-} -76
-.s configure -from 0 -to 2.25 -resolution 0
-update
-test scale-14.9 {RoundToResolution procedure} {
+} -result {-76}
+
+test scale-14.9 {RoundToResolution procedure} -body {
+ .s configure -from 0 -to 2.25 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 0
+ update
.s get 84 152
-} 1.64
-test scale-14.10 {RoundToResolution procedure} {
+} -result {1.64}
+test scale-14.10 {RoundToResolution procedure} -body {
+ .s configure -from 0 -to 2.25 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 0
+ update
.s get 86 152
-} 1.69
-.s configure -from 0 -to 225 -resolution 0 -digits 5
-update
-test scale-14.11 {RoundToResolution procedure} {
+} -result {1.69}
+
+test scale-14.11 {RoundToResolution procedure} -body {
+ .s configure -from 0 -to 225 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 0 -digits 5
+ update
.s get 84 152
-} 164.25
-test scale-14.12 {RoundToResolution procedure} {
+} -result {164.25}
+test scale-14.12 {RoundToResolution procedure} -body {
+ .s configure -from 0 -to 225 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 0 -digits 5
+ update
.s get 86 152
-} 168.75
+} -result {168.75}
+destroy .s
-test scale-15.1 {ScaleVarProc procedure} {
- catch {destroy .s}
+
+test scale-15.1 {ScaleVarProc procedure} -setup {
+ deleteWindows
+} -body {
set y -130
scale .s -from 0 -to -200 -variable y -orient horizontal -length 150
pack .s
- set y
-} -130
-test scale-15.2 {ScaleVarProc procedure} {
- catch {destroy .s}
+ return $y
+} -result {-130}
+test scale-15.2 {ScaleVarProc procedure} -setup {
+ deleteWindows
+} -body {
set y -130
scale .s -from -200 -to 0 -variable y -orient horizontal -length 150
pack .s
set y -87
.s get
-} -87
-test scale-15.3 {ScaleVarProc procedure} {
- catch {destroy .s}
+} -result {-87}
+test scale-15.3 {ScaleVarProc procedure} -setup {
+ deleteWindows
+} -body {
set y -130
scale .s -from -200 -to 0 -variable y -orient horizontal -length 150
pack .s
- list [catch {set y 40q} msg] $msg [.s get]
-} {1 {can't set "y": can't assign non-numeric value to scale variable} -130}
-test scale-15.4 {ScaleVarProc procedure} {
- catch {destroy .s}
+ set y 40q
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {can't set "y": can't assign non-numeric value to scale variable}
+test scale-15.4 {ScaleVarProc procedure} -setup {
+ deleteWindows
+} -body {
+ set y -130
+ scale .s -from -200 -to 0 -variable y -orient horizontal -length 150
+ pack .s
+ catch {set y 40q}
+ .s get
+} -cleanup {
+ deleteWindows
+} -result {-130}
+test scale-15.5 {ScaleVarProc procedure} -setup {
+ deleteWindows
+} -body {
+ set y 1
+ scale .s -from 1 -to 0 -variable y -orient horizontal -length 150
+ pack .s
+ set y x
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {can't set "y": can't assign non-numeric value to scale variable}
+test scale-15.6 {ScaleVarProc procedure} -setup {
+ deleteWindows
+} -body {
set y 1
scale .s -from 1 -to 0 -variable y -orient horizontal -length 150
pack .s
- list [catch {set y x} msg] $msg [.s get]
-} {1 {can't set "y": can't assign non-numeric value to scale variable} 1}
-test scale-15.5 {ScaleVarProc procedure, variable deleted} {
- catch {destroy .s}
+ catch {set y x}
+ .s get
+} -cleanup {
+ deleteWindows
+} -result 1
+test scale-15.7 {ScaleVarProc procedure, variable deleted} -setup {
+ deleteWindows
+} -body {
set y 6
scale .s -from 10 -to 0 -variable y -orient horizontal -length 150 \
- -command "set x"
+ -command "set x"
pack .s
update
set x untouched
unset y
update
list [catch {set y} msg] $msg [.s get] $x
-} {0 6 6 untouched}
-test scale-15.6 {ScaleVarProc procedure, don't call -command} {
- catch {destroy .s}
+} -cleanup {
+ deleteWindows
+} -result {0 6 6 untouched}
+test scale-15.8 {ScaleVarProc procedure, don't call -command} -setup {
+ deleteWindows
+} -body {
set y 6
scale .s -from 0 -to 100 -variable y -orient horizontal -length 150 \
- -command "set x"
+ -command "set x"
pack .s
update
set x untouched
set y 60
update
list $x [.s get]
-} {untouched 60}
+} -cleanup {
+ deleteWindows
+} -result {untouched 60}
-set l [interp hidden]
-deleteWindows
-test scale-16.1 {scale widget vs hidden commands} {
- catch {destroy .s}
+test scale-16.1 {scale widget vs hidden commands} -body {
+ set l [interp hidden]
+ deleteWindows
scale .s
interp hide {} .s
destroy .s
- list [winfo children .] [interp hidden]
-} [list {} $l]
+ set res1 [list [winfo children .] [interp hidden]]
+ set res2 [list {} $l]
+ expr {$res1 eq $res2}
+} -cleanup {
+ deleteWindows
+} -result 1
+
-test scale-17.1 {bug fix 1786} {
+test scale-17.1 {bug fix 1786} -setup {
+ deleteWindows
+} -body {
# Perhaps x is set to {}, depending on what other tests have run.
# If x is unset, or set to something not convertable to a double,
# then the scale try to initialize its value with the contents
@@ -803,66 +1301,62 @@ test scale-17.1 {bug fix 1786} {
# Bug 4833 changed the result to realize that x should pick up
# a value from the scale. In an FPE occurs, it is due to the
# lack of errno being set to 0 by some libc's. (see bug 4942)
- set x
-} {100}
+ return $x
+} -cleanup {
+ deleteWindows
+} -result {100}
+
-test scale-18.1 {DestroyScale, -cursor option [Bug: 3897]} {
- catch {destroy .s}
+test scale-18.1 {DestroyScale, -cursor option [Bug: 3897]} -setup {
+ deleteWindows
+} -body {
scale .s -cursor trek
destroy .s
-} {}
-
-test scale-18.2 {Scale button 1 events [Bug 787065]} \
- -setup {
- catch {destroy .s}
- set y 5
- scale .s -from 0 -to 10 -variable y -orient horizontal -length 150
- pack .s
- tkwait visibility .s
- set ::error {}
- proc bgerror {args} {set ::error $args}
- } \
- -body {
- list [catch {
- event generate .s <1> -x 0 -y 0
- event generate .s <ButtonRelease-1> -x 0 -y 0
- update
- set ::error
- } msg] $msg
- } \
- -cleanup {
- unset ::error
- rename bgerror {}
- catch {destroy .s}
- } \
- -result {0 {}}
-
-test scale-18.3 {Scale button 2 events [Bug 787065]} \
- -setup {
- catch {destroy .s}
- set y 5
- scale .s -from 0 -to 10 -variable y -orient horizontal -length 150
- pack .s
- tkwait visibility .s
- set ::error {}
- proc bgerror {args} {set ::error $args}
- } \
- -body {
- list [catch {
- event generate .s <2> -x 0 -y 0
- event generate .s <ButtonRelease-2> -x 0 -y 0
- update
- set ::error
- } msg] $msg
- } \
- -cleanup {
- unset ::error
- rename bgerror {}
- catch {destroy .s}
- } \
- -result {0 {}}
-
-catch {destroy .s}
+} -result {}
+
+test scale-18.2 {Scale button 1 events [Bug 787065]} -setup {
+ destroy .s
+ set ::error {}
+ proc bgerror {args} {set ::error $args}
+} -body {
+ set y 5
+ scale .s -from 0 -to 10 -variable y -orient horizontal -length 150
+ pack .s
+ tkwait visibility .s
+ list [catch {
+ event generate .s <1> -x 0 -y 0
+ event generate .s <ButtonRelease-1> -x 0 -y 0
+ update
+ set ::error
+ } msg] $msg
+} -cleanup {
+ unset ::error
+ rename bgerror {}
+ destroy .s
+} -result {0 {}}
+
+test scale-18.3 {Scale button 2 events [Bug 787065]} -setup {
+ destroy .s
+ set ::error {}
+ proc bgerror {args} {set ::error $args}
+} -body {
+ set y 5
+ scale .s -from 0 -to 10 -variable y -orient horizontal -length 150
+ pack .s
+ tkwait visibility .s
+ list [catch {
+ event generate .s <2> -x 0 -y 0
+ event generate .s <ButtonRelease-2> -x 0 -y 0
+ update
+ set ::error
+ } msg] $msg
+} -cleanup {
+ unset ::error
+ rename bgerror {}
+ destroy .s
+} -result {0 {}}
+
+
option clear
# cleanup
diff --git a/tests/scrollbar.test b/tests/scrollbar.test
index 5d4334f..3addd28 100644
--- a/tests/scrollbar.test
+++ b/tests/scrollbar.test
@@ -57,7 +57,7 @@ foreach test {
{-activebackground #ff0000 #ff0000 non-existent
{unknown color name "non-existent"}}
{-activerelief sunken sunken non-existent
- {bad relief type "non-existent": must be flat, groove, raised, ridge, solid, or sunken}}
+ {bad relief "non-existent": must be flat, groove, raised, ridge, solid, or sunken}}
{-background #ff0000 #ff0000 non-existent
{unknown color name "non-existent"}}
{-bd 4 4 badValue {bad screen distance "badValue"}}
@@ -75,7 +75,7 @@ foreach test {
{-orient horizontal horizontal badValue
{bad orientation "badValue": must be vertical or horizontal}}
{-orient horizontal horizontal bogus {bad orientation "bogus": must be vertical or horizontal}}
- {-relief ridge ridge badValue {bad relief type "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
+ {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
{-repeatdelay 140 140 129.3 {expected integer but got "129.3"}}
{-repeatinterval 140 140 129.3 {expected integer but got "129.3"}}
{-takefocus "any string" "any string" {} {}}
@@ -99,7 +99,7 @@ foreach test {
destroy .s
test scrollbar-2.1 {Tk_ScrollbarCmd procedure} -returnCodes error -body {
scrollbar
-} -result {wrong # args: should be "scrollbar pathName ?options?"}
+} -result {wrong # args: should be "scrollbar pathName ?-option value ...?"}
test scrollbar-2.2 {Tk_ScrollbarCmd procedure} -body {
scrollbar gorp
} -returnCodes error -result {bad window path name "gorp"}
@@ -127,7 +127,7 @@ pack .s -side right -fill y
update
test scrollbar-3.1 {ScrollbarWidgetCmd procedure} {
list [catch {.s} msg] $msg
-} {1 {wrong # args: should be ".s option ?arg arg ...?"}}
+} {1 {wrong # args: should be ".s option ?arg ...?"}}
test scrollbar-3.2 {ScrollbarWidgetCmd procedure, "cget" option} {
list [catch {.s cget} msg] $msg
} {1 {wrong # args: should be ".s cget option"}}
diff --git a/tests/select.test b/tests/select.test
index 8cbfd39..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..e3156a1 100644
--- a/tests/send.test
+++ b/tests/send.test
@@ -230,10 +230,10 @@ test send-8.4 {Tk_SendCmd procedure, options} {secureserver} {
} {1 {bad option "-gorp": must be -async, -displayof, or --}}
test send-8.5 {Tk_SendCmd procedure, options} {secureserver} {
list [catch {send -async foo} msg] $msg
-} {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}}
+} {1 {wrong # args: should be "send ?-option value ...? interpName arg ?arg ...?"}}
test send-8.6 {Tk_SendCmd procedure, options} {secureserver} {
list [catch {send foo} msg] $msg
-} {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}}
+} {1 {wrong # args: should be "send ?-option value ...? interpName arg ?arg ...?"}}
test send-8.7 {Tk_SendCmd procedure, local execution} {secureserver} {
set a initial
send [tk appname] {set a new}
diff --git a/tests/spinbox.test b/tests/spinbox.test
index 430e176..b8170c5 100644
--- a/tests/spinbox.test
+++ b/tests/spinbox.test
@@ -1,238 +1,1240 @@
# This file is a Tcl script to test spinbox widgets in Tk. It is
# organized in the standard fashion for Tcl tests.
#
-# Copyright (c) 1998-2000 by Scriptics Corporation.
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
+# For xscrollcommand
proc scroll args {
- global scrollInfo
- set scrollInfo $args
+ global scrollInfo
+ set scrollInfo $args
+}
+# For trace variable
+proc override args {
+ global x
+ set x 12345
}
-# Create additional widget that's used to hold the selection at times.
-
-spinbox .sel
-.sel insert end "This is some sample text"
-
-# Font names
-
-set big -adobe-helvetica-medium-r-normal--24-240-75-75-p-*-iso8859-1
-set fixed -adobe-courier-medium-r-normal--12-120-75-75-m-*-iso8859-1
-
-# Create entries in the option database to be sure that geometry options
-# like border width have predictable values.
-
-option add *Spinbox.borderWidth 2
-option add *Spinbox.highlightThickness 2
-option add *Spinbox.font {Helvetica -12}
-
-spinbox .e -bd 2 -relief sunken
-pack .e
-update
-
-set i 1
-foreach test {
- {-activebackground #ff0000 #ff0000 non-existent
- {unknown color name "non-existent"}}
- {-background #ff0000 #ff0000 non-existent
- {unknown color name "non-existent"}}
- {-bd 4 4 badValue {bad screen distance "badValue"}}
- {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}}
- {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
- {-buttonbackground #ff0000 #ff0000 non-existent
- {unknown color name "non-existent"}}
- {-buttoncursor arrow arrow badValue {bad cursor spec "badValue"}}
- {-command {a command} {a command} {} {}}
- {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
- {-disabledbackground green green non-existent
- {unknown color name "non-existent"}}
- {-disabledforeground #110022 #110022 bogus {unknown color name "bogus"}}
- {-exportselection yes 1 xyzzy {expected boolean value but got "xyzzy"}}
- {-fg #110022 #110022 bogus {unknown color name "bogus"}}
- {-font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
- -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* {}
- {font "" doesn't exist}}
- {-foreground #110022 #110022 bogus {unknown color name "bogus"}}
- {-format %0.5f %0.5f %d {bad spinbox format specifier "%d"}}
- {-from -10 -10.0 bogus {expected floating-point number but got "bogus"}}
- {-highlightbackground #123456 #123456 ugly {unknown color name "ugly"}}
- {-highlightcolor #123456 #123456 bogus {unknown color name "bogus"}}
- {-highlightthickness 6 6 bogus {bad screen distance "bogus"}}
- {-highlightthickness -2 0 {} {}}
- {-increment 1.0 1.0 bogus {expected floating-point number but got "bogus"}}
- {-insertbackground #110022 #110022 bogus {unknown color name "bogus"}}
- {-insertborderwidth 1.3 1 2.6x {bad screen distance "2.6x"}}
- {-insertofftime 100 100 3.2 {expected integer but got "3.2"}}
- {-insertontime 100 100 3.2 {expected integer but got "3.2"}}
- {-invalidcommand "a command" "a command" {} {}}
- {-invcmd "a command" "a command" {} {}}
- {-justify right right bogus {bad justification "bogus": must be left, right, or center}}
- {-readonlybackground green green non-existent
- {unknown color name "non-existent"}}
- {-relief groove groove 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}}
- {-repeatdelay 500 500 3p {expected integer but got "3p"}}
- {-repeatinterval -500 -500 3p {expected integer but got "3p"}}
- {-selectbackground #110022 #110022 bogus {unknown color name "bogus"}}
- {-selectborderwidth 1.3 1 badValue {bad screen distance "badValue"}}
- {-selectforeground #654321 #654321 bogus {unknown color name "bogus"}}
- {-state n normal bogus {bad state "bogus": must be disabled, normal, or readonly}}
- {-takefocus "any string" "any string" {} {}}
- {-textvariable i i {} {}}
- {-to 14.9 14.9 bogus {expected floating-point number but got "bogus"}}
- {-validate "key" "key" "bogus" {bad validate "bogus": must be all, key, focus, focusin, focusout, or none}}
- {-validatecommand "a command" "a command" {} {}}
- {-values {mon tue wed thur} {mon tue wed thur} {bad {}list} {list element in braces followed by "list" instead of space}}
- {-vcmd "a command" "a command" {} {}}
- {-width 402 402 3p {expected integer but got "3p"}}
- {-wrap yes 1 xyzzy {expected boolean value but got "xyzzy"}}
- {-xscrollcommand {Some command} {Some command} {} {}}
-} {
- set name [lindex $test 0]
- test spinbox-1.$i {configuration options} {
- .e configure $name [lindex $test 1]
- list [lindex [.e configure $name] 4] [.e cget $name]
- } [list [lindex $test 2] [lindex $test 2]]
- incr i
- if {[lindex $test 3] != ""} {
- test spinbox-1.$i {configuration options} {
- list [catch {.e configure $name [lindex $test 3]} msg] $msg
- } [list 1 [lindex $test 4]]
- }
- .e configure $name [lindex [.e configure $name] 3]
- incr i
+# Procedures used in widget VALIDATION tests
+proc doval {W d i P s S v V} {
+ set ::vVals [list $W $d $i $P $s $S $v $V]
+ return 1
+}
+proc doval2 {W d i P s S v V} {
+ set ::vVals [list $W $d $i $P $s $S $v $V]
+ set ::e mydata
+ return 1
+}
+proc doval3 {W d i P s S v V} {
+ set ::vVals [list $W $d $i $P $s $S $v $V]
+ return 0
}
-test spinbox-2.1 {Tk_SpinboxCmd procedure} {
- list [catch {spinbox} msg] $msg
-} {1 {wrong # args: should be "spinbox pathName ?options?"}}
-test spinbox-2.2 {Tk_SpinboxCmd procedure} {
- list [catch {spinbox gorp} msg] $msg
-} {1 {bad window path name "gorp"}}
-test spinbox-2.3 {Tk_SpinboxCmd procedure} {
- catch {destroy .e}
+set cy [font metrics {Courier -12} -linespace]
+
+test spinbox-1.1 {configuration option: "activebackground"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -activebackground #ff0000
+ .e cget -activebackground
+} -cleanup {
+ destroy .e
+} -result {#ff0000}
+test spinbox-1.2 {configuration option: "activebackground" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -activebackground non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test spinbox-1.3 {configuration option: "background"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -background #ff0000
+ .e cget -background
+} -cleanup {
+ destroy .e
+} -result {#ff0000}
+test spinbox-1.4 {configuration option: "background" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -background non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test spinbox-1.5 {configuration option: "bd"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -bd 4
+ .e cget -bd
+} -cleanup {
+ destroy .e
+} -result {4}
+test spinbox-1.6 {configuration option: "bd" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -bd badValue
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+test spinbox-1.7 {configuration option: "bg"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -bg #ff0000
+ .e cget -bg
+} -cleanup {
+ destroy .e
+} -result {#ff0000}
+test spinbox-1.8 {configuration option: "bg" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -bg non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test spinbox-1.9 {configuration option: "borderwidth"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -borderwidth 1.3
+ .e cget -borderwidth
+} -cleanup {
+ destroy .e
+} -result {1}
+test spinbox-1.10 {configuration option: "borderwidth" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -borderwidth badValue
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+test spinbox-1.11 {configuration option: "buttonbackground"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -buttonbackground #ff0000
+ .e cget -buttonbackground
+} -cleanup {
+ destroy .e
+} -result {#ff0000}
+test spinbox-1.12 {configuration option: "buttonbackground" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -buttonbackground non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test spinbox-1.13 {configuration option: "buttoncursor"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -buttoncursor arrow
+ .e cget -buttoncursor
+} -cleanup {
+ destroy .e
+} -result {arrow}
+test spinbox-1.14 {configuration option: "buttoncursor" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -buttoncursor badValue
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad cursor spec "badValue"}
+
+test spinbox-1.15 {configuration option: "command"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -command {a command}
+ .e cget -command
+} -cleanup {
+ destroy .e
+} -result {a command}
+
+test spinbox-1.16 {configuration option: "cursor"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -cursor arrow
+ .e cget -cursor
+} -cleanup {
+ destroy .e
+} -result {arrow}
+test spinbox-1.17 {configuration option: "cursor" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -cursor badValue
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad cursor spec "badValue"}
+
+test spinbox-1.18 {configuration option: "disabledbackground"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -disabledbackground green
+ .e cget -disabledbackground
+} -cleanup {
+ destroy .e
+} -result {green}
+test spinbox-1.19 {configuration option: "disabledbackground" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -disabledbackground non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test spinbox-1.20 {configuration option: "disabledforeground"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -disabledforeground #110022
+ .e cget -disabledforeground
+} -cleanup {
+ destroy .e
+} -result {#110022}
+test spinbox-1.21 {configuration option: "disabledforeground" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -disabledforeground bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "bogus"}
+
+test spinbox-1.22 {configuration option: "exportselection"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -exportselection yes
+ .e cget -exportselection
+} -cleanup {
+ destroy .e
+} -result {1}
+test spinbox-1.23 {configuration option: "exportselection" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -exportselection xyzzy
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected boolean value but got "xyzzy"}
+
+test spinbox-1.24 {configuration option: "fg"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -fg #110022
+ .e cget -fg
+} -cleanup {
+ destroy .e
+} -result {#110022}
+test spinbox-1.25 {configuration option: "fg" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -fg bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "bogus"}
+
+test spinbox-1.26 {configuration option: "font"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*
+ .e cget -font
+} -cleanup {
+ destroy .e
+} -result {-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*}
+test spinbox-1.27 {configuration option: "font" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -font {}
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {font "" doesn't exist}
+
+test spinbox-1.28 {configuration option: "foreground"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -foreground #110022
+ .e cget -foreground
+} -cleanup {
+ destroy .e
+} -result {#110022}
+test spinbox-1.29 {configuration option: "foreground" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -foreground bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "bogus"}
+
+test spinbox-1.30 {configuration option: "format"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -format %0.5f
+ .e cget -format
+} -cleanup {
+ destroy .e
+} -result {%0.5f}
+test spinbox-1.31 {configuration option: "format" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -format %d
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad spinbox format specifier "%d"}
+
+test spinbox-1.32 {configuration option: "from"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -from -10
+ .e cget -from
+} -cleanup {
+ destroy .e
+} -result {-10.0}
+test spinbox-1.33 {configuration option: "from" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -from bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected floating-point number but got "bogus"}
+
+test spinbox-1.34 {configuration option: "highlightbackground"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -highlightbackground #123456
+ .e cget -highlightbackground
+} -cleanup {
+ destroy .e
+} -result {#123456}
+test spinbox-1.35 {configuration option: "highlightbackground" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -highlightbackground ugly
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "ugly"}
+
+test spinbox-1.36 {configuration option: "highlightcolor"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -highlightcolor #123456
+ .e cget -highlightcolor
+} -cleanup {
+ destroy .e
+} -result {#123456}
+test spinbox-1.37 {configuration option: "highlightcolor" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -highlightcolor bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "bogus"}
+
+test spinbox-1.38 {configuration option: "highlightthickness"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -highlightthickness 6
+ .e cget -highlightthickness
+} -cleanup {
+ destroy .e
+} -result {6}
+test spinbox-1.39 {configuration option: "highlightthickness" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -highlightthickness bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad screen distance "bogus"}
+
+test spinbox-1.40 {configuration option: "highlightthickness"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -highlightthickness -2
+ .e cget -highlightthickness
+} -cleanup {
+ destroy .e
+} -result {0}
+
+test spinbox-1.41 {configuration option: "increment"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -increment 1.0
+ .e cget -increment
+} -cleanup {
+ destroy .e
+} -result {1.0}
+test spinbox-1.42 {configuration option: "increment" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -increment bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected floating-point number but got "bogus"}
+
+test spinbox-1.43 {configuration option: "insertbackground"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -insertbackground #110022
+ .e cget -insertbackground
+} -cleanup {
+ destroy .e
+} -result {#110022}
+test spinbox-1.44 {configuration option: "insertbackground" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -insertbackground bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "bogus"}
+
+test spinbox-1.45 {configuration option: "insertborderwidth"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -insertborderwidth 1.3
+ .e cget -insertborderwidth
+} -cleanup {
+ destroy .e
+} -result {1}
+test spinbox-1.46 {configuration option: "insertborderwidth" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -insertborderwidth 2.6x
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad screen distance "2.6x"}
+
+test spinbox-1.47 {configuration option: "insertofftime"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -insertofftime 100
+ .e cget -insertofftime
+} -cleanup {
+ destroy .e
+} -result {100}
+test spinbox-1.48 {configuration option: "insertofftime" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -insertofftime 3.2
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected integer but got "3.2"}
+
+test spinbox-1.49 {configuration option: "insertontime"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -insertontime 100
+ .e cget -insertontime
+} -cleanup {
+ destroy .e
+} -result {100}
+test spinbox-1.50 {configuration option: "insertontime" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -insertontime 3.2
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected integer but got "3.2"}
+
+test spinbox-1.51 {configuration option: "invalidcommand"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -invalidcommand "a command"
+ .e cget -invalidcommand
+} -cleanup {
+ destroy .e
+} -result {a command}
+
+test spinbox-1.52 {configuration option: "invcmd"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -invcmd "a command"
+ .e cget -invcmd
+} -cleanup {
+ destroy .e
+} -result {a command}
+
+test spinbox-1.53 {configuration option: "justify"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -justify right
+ .e cget -justify
+} -cleanup {
+ destroy .e
+} -result {right}
+test spinbox-1.54 {configuration option: "justify" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -justify bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad justification "bogus": must be left, right, or center}
+
+test spinbox-1.55 {configuration option: "readonlybackground"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -readonlybackground green
+ .e cget -readonlybackground
+} -cleanup {
+ destroy .e
+} -result {green}
+test spinbox-1.56 {configuration option: "readonlybackground" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -readonlybackground non-existent
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "non-existent"}
+
+test spinbox-1.57 {configuration option: "relief"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -relief groove
+ .e cget -relief
+} -cleanup {
+ destroy .e
+} -result {groove}
+test spinbox-1.58 {configuration option: "relief" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -relief 1.5
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
+
+test spinbox-1.59 {configuration option: "repeatdelay"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -repeatdelay 500
+ .e cget -repeatdelay
+} -cleanup {
+ destroy .e
+} -result {500}
+test spinbox-1.60 {configuration option: "repeatdelay" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -repeatdelay 3p
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected integer but got "3p"}
+
+test spinbox-1.61 {configuration option: "repeatinterval"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -repeatinterval -500
+ .e cget -repeatinterval
+} -cleanup {
+ destroy .e
+} -result {-500}
+test spinbox-1.62 {configuration option: "repeatinterval" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -repeatinterval 3p
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected integer but got "3p"}
+
+test spinbox-1.63 {configuration option: "selectbackground"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -selectbackground #110022
+ .e cget -selectbackground
+} -cleanup {
+ destroy .e
+} -result {#110022}
+test spinbox-1.64 {configuration option: "selectbackground" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -selectbackground bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "bogus"}
+
+test spinbox-1.65 {configuration option: "selectborderwidth"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -selectborderwidth 1.3
+ .e cget -selectborderwidth
+} -cleanup {
+ destroy .e
+} -result {1}
+test spinbox-1.66 {configuration option: "selectborderwidth" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -selectborderwidth badValue
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad screen distance "badValue"}
+
+test spinbox-1.67 {configuration option: "selectforeground"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -selectforeground #654321
+ .e cget -selectforeground
+} -cleanup {
+ destroy .e
+} -result {#654321}
+test spinbox-1.68 {configuration option: "selectforeground" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -selectforeground bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {unknown color name "bogus"}
+
+test spinbox-1.69 {configuration option: "state"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -state n
+ .e cget -state
+} -cleanup {
+ destroy .e
+} -result {normal}
+test spinbox-1.70 {configuration option: "state" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -state bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad state "bogus": must be disabled, normal, or readonly}
+
+test spinbox-1.71 {configuration option: "takefocus"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -takefocus "any string"
+ .e cget -takefocus
+} -cleanup {
+ destroy .e
+} -result {any string}
+
+test spinbox-1.72 {configuration option: "textvariable"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -textvariable i
+ .e cget -textvariable
+} -cleanup {
+ destroy .e
+} -result {i}
+
+test spinbox-1.73 {configuration option: "to"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -to 14.9
+ .e cget -to
+} -cleanup {
+ destroy .e
+} -result {14.9}
+test spinbox-1.74 {configuration option: "to" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -to bogus
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected floating-point number but got "bogus"}
+
+test spinbox-1.75 {configuration option: "validate"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -validate "key"
+ .e cget -validate
+} -cleanup {
+ destroy .e
+} -result {key}
+test spinbox-1.76 {configuration option: "validate" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -validate "bogus"
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad validate "bogus": must be all, key, focus, focusin, focusout, or none}
+
+test spinbox-1.77 {configuration option: "validatecommand"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -validatecommand "a command"
+ .e cget -validatecommand
+} -cleanup {
+ destroy .e
+} -result {a command}
+
+test spinbox-1.78 {configuration option: "values"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -values {mon tue wed thur}
+ .e cget -values
+} -cleanup {
+ destroy .e
+} -result {mon tue wed thur}
+test spinbox-1.79 {configuration option: "values" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -values {bad {}list}
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {list element in braces followed by "list" instead of space}
+
+test spinbox-1.80 {configuration option: "vcmd"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -vcmd "a command"
+ .e cget -vcmd
+} -cleanup {
+ destroy .e
+} -result {a command}
+
+test spinbox-1.81 {configuration option: "width"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -width 402
+ .e cget -width
+} -cleanup {
+ destroy .e
+} -result {402}
+test spinbox-1.82 {configuration option: "width" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -width 3p
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected integer but got "3p"}
+
+test spinbox-1.83 {configuration option: "wrap"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -wrap yes
+ .e cget -wrap
+} -cleanup {
+ destroy .e
+} -result {1}
+test spinbox-1.84 {configuration option: "wrap" for spinbox} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -wrap xyzzy
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {expected boolean value but got "xyzzy"}
+
+test spinbox-1.85 {configuration option: "xscrollcommand"} -setup {
+ spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
+ -relief sunken
+ pack .e
+ update
+} -body {
+ .e configure -xscrollcommand {Some command}
+ .e cget -xscrollcommand
+} -cleanup {
+ destroy .e
+} -result {Some command}
+
+
+test spinbox-2.1 {Tk_SpinboxCmd procedure} -body {
+ spinbox
+} -returnCodes error -result {wrong # args: should be "spinbox pathName ?-option value ...?"}
+test spinbox-2.2 {Tk_SpinboxCmd procedure} -body {
+ spinbox gorp
+} -returnCodes error -result {bad window path name "gorp"}
+test spinbox-2.3 {Tk_SpinboxCmd procedure} -body {
spinbox .e
+ pack .e
+ update
list [winfo exists .e] [winfo class .e] [info commands .e]
-} {1 Spinbox .e}
-test spinbox-2.4 {Tk_SpinboxCmd procedure} {
- catch {destroy .e}
- list [catch {spinbox .e -gorp foo} msg] $msg [winfo exists .e] \
- [info commands .e]
-} {1 {unknown option "-gorp"} 0 {}}
-test spinbox-2.5 {Tk_SpinboxCmd procedure} {
- catch {destroy .e}
+} -cleanup {
+ destroy .e
+} -result {1 Spinbox .e}
+test spinbox-2.4 {Tk_SpinboxCmd procedure} -body {
+ spinbox .e -gorp foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {unknown option "-gorp"}
+test spinbox-2.4.1 {Tk_SpinboxCmd procedure} -body {
+ catch {spinbox .e -gorp foo}
+ list [winfo exists .e] [info commands .e]
+} -cleanup {
+ destroy .e
+} -result {0 {}}
+test spinbox-2.5 {Tk_SpinboxCmd procedure} -body {
spinbox .e
-} {.e}
-
-catch {destroy .e}
-spinbox .e -font $fixed
-pack .e
-update
-
-set cx [font measure $fixed a]
-set cy [font metrics $fixed -linespace]
-set ux [font measure $fixed \u4e4e]
-
-test spinbox-3.1 {SpinboxWidgetCmd procedure} {
- list [catch {.e} msg] $msg
-} {1 {wrong # args: should be ".e option ?arg arg ...?"}}
-test spinbox-3.2 {SpinboxWidgetCmd procedure, "bbox" widget command} {
- list [catch {.e bbox} msg] $msg
-} {1 {wrong # args: should be ".e bbox index"}}
-test spinbox-3.3 {SpinboxWidgetCmd procedure, "bbox" widget command} {
- list [catch {.e bbox a b} msg] $msg
-} {1 {wrong # args: should be ".e bbox index"}}
-test spinbox-3.4 {SpinboxWidgetCmd procedure, "bbox" widget command} {
- list [catch {.e bbox bogus} msg] $msg
-} {1 {bad spinbox index "bogus"}}
-test spinbox-3.5 {SpinboxWidgetCmd procedure, "bbox" widget command} {
- .e delete 0 end
- .e bbox 0
-} [list 5 5 0 $cy]
-test spinbox-3.6 {SpinboxWidgetCmd procedure, "bbox" widget command} {
- # Tcl_UtfAtIndex(): no utf chars
+} -cleanup {
+ destroy .e
+} -result {.e}
- .e delete 0 end
+
+test spinbox-3.1 {SpinboxWidgetCmd procedure} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e option ?arg ...?"}
+test spinbox-3.2 {SpinboxWidgetCmd procedure, "bbox" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e bbox
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e bbox index"}
+test spinbox-3.3 {SpinboxWidgetCmd procedure, "bbox" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e bbox a b
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e bbox index"}
+test spinbox-3.4 {SpinboxWidgetCmd procedure, "bbox" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e bbox bogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad spinbox index "bogus"}
+test spinbox-3.5 {SpinboxWidgetCmd procedure, "bbox" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e bbox 0
+} -cleanup {
+ destroy .e
+} -result [list 5 5 0 $cy]
+
+# Oryginaly the result was count using measurements
+# and metrics. It was changed to less verbose solution - the result is the one
+# that passes fonts constraint (this concerns tests 3.6, 3.7, 3.8, 3.10)
+test spinbox-3.6 {SpinboxWidgetCmd procedure, "bbox" widget command} -constraints {
+ fonts
+} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+# Tcl_UtfAtIndex(): no utf chars
.e insert 0 "abc"
list [.e bbox 3] [.e bbox end]
-} [list "[expr 5+2*$cx] 5 $cx $cy" "[expr 5+2*$cx] 5 $cx $cy"]
-test spinbox-3.7 {SpinboxWidgetCmd procedure, "bbox" widget command} {
- # Tcl_UtfAtIndex(): utf at end
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {{19 5 7 13} {19 5 7 13}}
+test spinbox-3.7 {SpinboxWidgetCmd procedure, "bbox" widget command} -constraints {
+ fonts
+} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+# Tcl_UtfAtIndex(): utf at end
.e insert 0 "ab\u4e4e"
.e bbox end
-} "[expr 5+2*$cx] 5 $ux $cy"
-test spinbox-3.8 {SpinboxWidgetCmd procedure, "bbox" widget command} {
- # Tcl_UtfAtIndex(): utf before index
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {19 5 12 13}
+test spinbox-3.8 {SpinboxWidgetCmd procedure, "bbox" widget command} -constraints {
+ fonts
+} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+# Tcl_UtfAtIndex(): utf before index
.e insert 0 "ab\u4e4ec"
.e bbox 3
-} "[expr 5+2*$cx+$ux] 5 $cx $cy"
-test spinbox-3.9 {SpinboxWidgetCmd procedure, "bbox" widget command} {
- # Tcl_UtfAtIndex(): no chars
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {31 5 7 13}
+test spinbox-3.9 {SpinboxWidgetCmd procedure, "bbox" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+# Tcl_UtfAtIndex(): no chars
.e bbox end
-} "5 5 0 $cy"
-test spinbox-3.10 {SpinboxWidgetCmd procedure, "bbox" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result "5 5 0 $cy"
+test spinbox-3.10 {SpinboxWidgetCmd procedure, "bbox" widget command} -constraints {
+ fonts
+} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
.e insert 0 "abcdefghij\u4e4eklmnop"
list [.e bbox 0] [.e bbox 1] [.e bbox 10] [.e bbox end]
-} [list "5 5 $cx $cy" "[expr 5+$cx] 5 $cx $cy" "[expr 5+10*$cx] 5 $ux $cy" "[expr 5+$ux+15*$cx] 5 $cx $cy"]
-test spinbox-3.11 {SpinboxWidgetCmd procedure, "cget" widget command} {
- list [catch {.e cget} msg] $msg
-} {1 {wrong # args: should be ".e cget option"}}
-test spinbox-3.12 {SpinboxWidgetCmd procedure, "cget" widget command} {
- list [catch {.e cget a b} msg] $msg
-} {1 {wrong # args: should be ".e cget option"}}
-test spinbox-3.13 {SpinboxWidgetCmd procedure, "cget" widget command} {
- list [catch {.e cget -gorp} msg] $msg
-} {1 {unknown option "-gorp"}}
-test spinbox-3.14 {SpinboxWidgetCmd procedure, "cget" widget command} {
+} -cleanup {
+ destroy .e
+} -result {{5 5 7 13} {12 5 7 13} {75 5 12 13} {122 5 7 13}}
+test spinbox-3.11 {SpinboxWidgetCmd procedure, "cget" widget command} -setup {
+ spinbox .e
+} -body {
+ .e cget
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e cget option"}
+test spinbox-3.12 {SpinboxWidgetCmd procedure, "cget" widget command} -setup {
+ spinbox .e
+} -body {
+ .e cget a b
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e cget option"}
+test spinbox-3.13 {SpinboxWidgetCmd procedure, "cget" widget command} -setup {
+ spinbox .e
+} -body {
+ .e cget -gorp
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {unknown option "-gorp"}
+test spinbox-3.14 {SpinboxWidgetCmd procedure, "cget" widget command} -setup {
+ spinbox .e
+} -body {
.e configure -bd 4
.e cget -bd
-} {4}
-test spinbox-3.15 {SpinboxWidgetCmd procedure, "configure" widget command} {
+} -cleanup {
+ destroy .e
+} -result {4}
+test spinbox-3.15 {SpinboxWidgetCmd procedure, "configure" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
llength [.e configure]
-} {49}
-test spinbox-3.16 {SpinboxWidgetCmd procedure, "configure" widget command} {
- list [catch {.e configure -foo} msg] $msg
-} {1 {unknown option "-foo"}}
-test spinbox-3.17 {SpinboxWidgetCmd procedure, "configure" widget command} {
+} -cleanup {
+ destroy .e
+} -result {49}
+test spinbox-3.16 {SpinboxWidgetCmd procedure, "configure" widget command} -setup {
+ spinbox .e
+} -body {
+ .e configure -foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {unknown option "-foo"}
+test spinbox-3.17 {SpinboxWidgetCmd procedure, "configure" widget command} -setup {
+ spinbox .e
+} -body {
.e configure -bd 4
.e configure -bg #ffffff
lindex [.e configure -bd] 4
-} {4}
-test spinbox-3.18 {SpinboxWidgetCmd procedure, "delete" widget command} {
- list [catch {.e delete} msg] $msg
-} {1 {wrong # args: should be ".e delete firstIndex ?lastIndex?"}}
-test spinbox-3.19 {SpinboxWidgetCmd procedure, "delete" widget command} {
- list [catch {.e delete a b c} msg] $msg
-} {1 {wrong # args: should be ".e delete firstIndex ?lastIndex?"}}
-test spinbox-3.20 {SpinboxWidgetCmd procedure, "delete" widget command} {
- list [catch {.e delete foo} msg] $msg
-} {1 {bad spinbox index "foo"}}
-test spinbox-3.21 {SpinboxWidgetCmd procedure, "delete" widget command} {
- list [catch {.e delete 0 bar} msg] $msg
-} {1 {bad spinbox index "bar"}}
-test spinbox-3.22 {SpinboxWidgetCmd procedure, "delete" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {4}
+test spinbox-3.18 {SpinboxWidgetCmd procedure, "delete" widget command} -setup {
+ spinbox .e
+} -body {
+ .e delete
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e delete firstIndex ?lastIndex?"}
+test spinbox-3.19 {SpinboxWidgetCmd procedure, "delete" widget command} -setup {
+ spinbox .e
+} -body {
+ .e delete a b c
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e delete firstIndex ?lastIndex?"}
+test spinbox-3.20 {SpinboxWidgetCmd procedure, "delete" widget command} -setup {
+ spinbox .e
+} -body {
+ .e delete foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad spinbox index "foo"}
+test spinbox-3.21 {SpinboxWidgetCmd procedure, "delete" widget command} -setup {
+ spinbox .e
+} -body {
+ .e delete 0 bar
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad spinbox index "bar"}
+test spinbox-3.22 {SpinboxWidgetCmd procedure, "delete" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
.e insert end "01234567890"
.e delete 2 4
.e get
-} {014567890}
-test spinbox-3.23 {SpinboxWidgetCmd procedure, "delete" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {014567890}
+test spinbox-3.23 {SpinboxWidgetCmd procedure, "delete" widget command} -setup {
+ spinbox .e
+} -body {
.e insert end "01234567890"
.e delete 6
.e get
-} {0123457890}
-test spinbox-3.24 {SpinboxWidgetCmd procedure, "delete" widget command} {
- # UTF
+} -cleanup {
+ destroy .e
+} -result {0123457890}
+test spinbox-3.24 {SpinboxWidgetCmd procedure, "delete" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
set x {}
- .e delete 0 end
+} -body {
+# UTF
.e insert end "01234\u4e4e67890"
.e delete 6
lappend x [.e get]
@@ -244,277 +1246,659 @@ test spinbox-3.24 {SpinboxWidgetCmd procedure, "delete" widget command} {
.e insert end "0123456\u4e4e890"
.e delete 6
lappend x [.e get]
-} [list "01234\u4e4e7890" "0123457890" "012345\u4e4e890"]
-test spinbox-3.25 {SpinboxWidgetCmd procedure, "delete" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result [list "01234\u4e4e7890" "0123457890" "012345\u4e4e890"]
+test spinbox-3.25 {SpinboxWidgetCmd procedure, "delete" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
.e insert end "01234567890"
.e delete 6 5
.e get
-} {01234567890}
-test spinbox-3.26 {SpinboxWidgetCmd procedure, "delete" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {01234567890}
+test spinbox-3.26 {SpinboxWidgetCmd procedure, "delete" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
.e insert end "01234567890"
.e configure -state disabled
.e delete 2 8
.e configure -state normal
.e get
-} {01234567890}
-test spinbox-3.27 {SpinboxWidgetCmd procedure, "get" widget command} {
- list [catch {.e get foo} msg] $msg
-} {1 {wrong # args: should be ".e get"}}
-test spinbox-3.28 {SpinboxWidgetCmd procedure, "icursor" widget command} {
- list [catch {.e icursor} msg] $msg
-} {1 {wrong # args: should be ".e icursor pos"}}
-test spinbox-3.29 {SpinboxWidgetCmd procedure, "icursor" widget command} {
- list [catch {.e icursor foo} msg] $msg
-} {1 {bad spinbox index "foo"}}
-test spinbox-3.30 {SpinboxWidgetCmd procedure, "icursor" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {01234567890}
+test spinbox-3.26.1 {SpinboxWidgetCmd procedure, "delete" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e insert end "01234567890"
+ .e configure -state readonly
+ .e delete 2 8
+ .e configure -state normal
+ .e get
+} -cleanup {
+ destroy .e
+} -result {01234567890}
+test spinbox-3.27 {SpinboxWidgetCmd procedure, "get" widget command} -setup {
+ spinbox .e
+} -body {
+ .e get foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e get"}
+test spinbox-3.28 {SpinboxWidgetCmd procedure, "icursor" widget command} -setup {
+ spinbox .e
+} -body {
+ .e icursor
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e icursor pos"}
+test spinbox-3.29 {SpinboxWidgetCmd procedure, "icursor" widget command} -setup {
+ spinbox .e
+} -body {
+ .e icursor foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad spinbox index "foo"}
+test spinbox-3.30 {SpinboxWidgetCmd procedure, "icursor" widget command} -setup {
+ spinbox .e
+} -body {
.e insert end "01234567890"
.e icursor 4
.e index insert
-} {4}
-test spinbox-3.31 {SpinboxWidgetCmd procedure, "index" widget command} {
- list [catch {.e in} msg] $msg
-} {1 {ambiguous option "in": must be bbox, cget, configure, delete, get, icursor, identify, index, insert, invoke, scan, selection, set, validate, or xview}}
-test spinbox-3.32 {SpinboxWidgetCmd procedure, "index" widget command} {
- list [catch {.e index} msg] $msg
-} {1 {wrong # args: should be ".e index string"}}
-test spinbox-3.33 {SpinboxWidgetCmd procedure, "index" widget command} {
- list [catch {.e index foo} msg] $msg
-} {1 {bad spinbox index "foo"}}
-test spinbox-3.34 {SpinboxWidgetCmd procedure, "index" widget command} {
- list [catch {.e index 0} msg] $msg
-} {0 0}
-test spinbox-3.35 {SpinboxWidgetCmd procedure, "index" widget command} {
- # UTF
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {4}
+test spinbox-3.31 {SpinboxWidgetCmd procedure, "index" widget command} -setup {
+ spinbox .e
+} -body {
+ .e in
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {ambiguous option "in": must be bbox, cget, configure, delete, get, icursor, identify, index, insert, invoke, scan, selection, set, validate, or xview}
+test spinbox-3.32 {SpinboxWidgetCmd procedure, "index" widget command} -setup {
+ spinbox .e
+} -body {
+ .e index
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e index string"}
+test spinbox-3.33 {SpinboxWidgetCmd procedure, "index" widget command} -setup {
+ spinbox .e
+} -body {
+ .e index foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad spinbox index "foo"}
+test spinbox-3.34 {SpinboxWidgetCmd procedure, "index" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e index 0
+} -cleanup {
+ destroy .e
+} -returnCodes {ok} -match glob -result {*}
+test spinbox-3.35 {SpinboxWidgetCmd procedure, "index" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+# UTF
.e insert 0 abc\u4e4e\u0153def
list [.e index 3] [.e index 4] [.e index end]
-} {3 4 8}
-test spinbox-3.36 {SpinboxWidgetCmd procedure, "insert" widget command} {
- list [catch {.e insert a} msg] $msg
-} {1 {wrong # args: should be ".e insert index text"}}
-test spinbox-3.37 {SpinboxWidgetCmd procedure, "insert" widget command} {
- list [catch {.e insert a b c} msg] $msg
-} {1 {wrong # args: should be ".e insert index text"}}
-test spinbox-3.38 {SpinboxWidgetCmd procedure, "insert" widget command} {
- list [catch {.e insert foo Text} msg] $msg
-} {1 {bad spinbox index "foo"}}
-test spinbox-3.39 {SpinboxWidgetCmd procedure, "insert" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {3 4 8}
+test spinbox-3.36 {SpinboxWidgetCmd procedure, "insert" widget command} -setup {
+ spinbox .e
+} -body {
+ .e insert a
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e insert index text"}
+test spinbox-3.37 {SpinboxWidgetCmd procedure, "insert" widget command} -setup {
+ spinbox .e
+} -body {
+ .e insert a b c
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e insert index text"}
+test spinbox-3.38 {SpinboxWidgetCmd procedure, "insert" widget command} -setup {
+ spinbox .e
+} -body {
+ .e insert foo Text
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad spinbox index "foo"}
+test spinbox-3.39 {SpinboxWidgetCmd procedure, "insert" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
.e insert end "01234567890"
.e insert 3 xxx
.e get
-} {012xxx34567890}
-test spinbox-3.40 {SpinboxWidgetCmd procedure, "insert" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {012xxx34567890}
+test spinbox-3.40 {SpinboxWidgetCmd procedure, "insert" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
.e insert end "01234567890"
.e configure -state disabled
.e insert 3 xxx
.e configure -state normal
.e get
-} {01234567890}
-test spinbox-3.41 {SpinboxWidgetCmd procedure, "insert" widget command} {
- list [catch {.e insert a b c} msg] $msg
-} {1 {wrong # args: should be ".e insert index text"}}
-test spinbox-3.42 {SpinboxWidgetCmd procedure, "scan" widget command} {
- list [catch {.e scan a} msg] $msg
-} {1 {wrong # args: should be ".e scan mark|dragto x"}}
-test spinbox-3.43 {SpinboxWidgetCmd procedure, "scan" widget command} {
- list [catch {.e scan a b c} msg] $msg
-} {1 {wrong # args: should be ".e scan mark|dragto x"}}
-test spinbox-3.44 {SpinboxWidgetCmd procedure, "scan" widget command} {
- list [catch {.e scan foobar 20} msg] $msg
-} {1 {bad scan option "foobar": must be mark or dragto}}
-test spinbox-3.45 {SpinboxWidgetCmd procedure, "scan" widget command} {
- list [catch {.e scan mark 20.1} msg] $msg
-} {1 {expected integer but got "20.1"}}
-# This test is non-portable because character sizes vary.
+} -cleanup {
+ destroy .e
+} -result {01234567890}
+test spinbox-3.40.1 {SpinboxWidgetCmd procedure, "insert" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e insert end "01234567890"
+ .e configure -state readonly
+ .e insert 3 xxx
+ .e configure -state normal
+ .e get
+} -cleanup {
+ destroy .e
+} -result {01234567890}
+test spinbox-3.41 {SpinboxWidgetCmd procedure, "insert" widget command} -setup {
+ spinbox .e
+} -body {
+ .e insert a b c
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e insert index text"}
+test spinbox-3.42 {SpinboxWidgetCmd procedure, "scan" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e scan a
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e scan mark|dragto x"}
+test spinbox-3.43 {SpinboxWidgetCmd procedure, "scan" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e scan a b c
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e scan mark|dragto x"}
+test spinbox-3.44 {SpinboxWidgetCmd procedure, "scan" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e scan foobar 20
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad scan option "foobar": must be mark or dragto}
+test spinbox-3.45 {SpinboxWidgetCmd procedure, "scan" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e scan mark 20.1
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {expected integer but got "20.1"}
-test spinbox-3.46 {SpinboxWidgetCmd procedure, "scan" widget command} {fonts} {
- .e delete 0 end
+# This test is non-portable because character sizes vary.
+test spinbox-3.46 {SpinboxWidgetCmd procedure, "scan" widget command} -constraints {
+ fonts
+} -setup {
+ spinbox .e -font {Helvetica -12} -borderwidth 2 -highlightthickness 2
+ pack .e
update
+} -body {
.e insert end "This is quite a long string, in fact a "
.e insert end "very very long string"
.e scan mark 30
.e scan dragto 28
.e index @0
-} {2}
-test spinbox-3.47 {SpinboxWidgetCmd procedure, "select" widget command} {
- list [catch {.e select} msg] $msg
-} {1 {wrong # args: should be ".e selection option ?index?"}}
-test spinbox-3.48 {SpinboxWidgetCmd procedure, "select" widget command} {
- list [catch {.e select foo} msg] $msg
-} {1 {bad selection option "foo": must be adjust, clear, element, from, present, range, or to}}
-test spinbox-3.49 {SpinboxWidgetCmd procedure, "select clear" widget command} {
- list [catch {.e select clear gorp} msg] $msg
-} {1 {wrong # args: should be ".e selection clear"}}
-test spinbox-3.50 {SpinboxWidgetCmd procedure, "select clear" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {2}
+test spinbox-3.47 {SpinboxWidgetCmd procedure, "select" widget command} -setup {
+ spinbox .e
+} -body {
+ .e select
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection option ?index?"}
+test spinbox-3.48 {SpinboxWidgetCmd procedure, "select" widget command} -setup {
+ spinbox .e
+} -body {
+ .e select foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad selection option "foo": must be adjust, clear, element, from, present, range, or to}
+
+test spinbox-3.49 {SpinboxWidgetCmd procedure, "select clear" widget command} -setup {
+ spinbox .e
+} -body {
+ .e select clear gorp
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection clear"}
+test spinbox-3.50 {SpinboxWidgetCmd procedure, "select clear" widget command} -setup {
+ spinbox .e
+} -body {
.e insert end "0123456789"
.e select from 1
.e select to 4
update
.e select clear
- list [catch {selection get} msg] $msg [selection own]
-} {1 {PRIMARY selection doesn't exist or form "STRING" not defined} .e}
-test spinbox-3.51 {SpinboxWidgetCmd procedure, "selection present" widget command} {
- list [catch {.e selection present foo} msg] $msg
-} {1 {wrong # args: should be ".e selection present"}}
-test spinbox-3.52 {SpinboxWidgetCmd procedure, "selection present" widget command} {
- .e delete 0 end
+ selection get
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {PRIMARY selection doesn't exist or form "STRING" not defined}
+test spinbox-3.50.1 {SpinboxWidgetCmd procedure, "select clear" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e insert end "0123456789"
+ .e select from 1
+ .e select to 4
+ update
+ .e select clear
+ catch {selection get}
+ selection own
+} -cleanup {
+ destroy .e
+} -result {.e}
+
+test spinbox-3.51 {SpinboxWidgetCmd procedure, "selection present" widget command} -setup {
+ spinbox .e
+} -body {
+ .e selection present foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection present"}
+test spinbox-3.52 {SpinboxWidgetCmd procedure, "selection present" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
.e insert end 0123456789
.e select from 3
.e select to 6
.e selection present
-} {1}
-test spinbox-3.53 {SpinboxWidgetCmd procedure, "selection present" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {1}
+test spinbox-3.53 {SpinboxWidgetCmd procedure, "selection present" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
.e insert end 0123456789
.e select from 3
.e select to 6
.e configure -exportselection false
.e selection present
-} {1}
-.e configure -exportselection true
-test spinbox-3.54 {SpinboxWidgetCmd procedure, "selection present" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {1}
+test spinbox-3.54 {SpinboxWidgetCmd procedure, "selection present" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
.e insert end 0123456789
.e select from 3
.e select to 6
.e delete 0 end
.e selection present
-} {0}
-test spinbox-3.55 {SpinboxWidgetCmd procedure, "selection adjust" widget command} {
- list [catch {.e select adjust x} msg] $msg
-} {1 {bad spinbox index "x"}}
-test spinbox-3.56 {SpinboxWidgetCmd procedure, "selection adjust" widget command} {
- list [catch {.e select adjust 2 3} msg] $msg
-} {1 {wrong # args: should be ".e selection adjust index"}}
-test spinbox-3.57 {SpinboxWidgetCmd procedure, "selection adjust" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {0}
+test spinbox-3.55 {SpinboxWidgetCmd procedure, "selection adjust" widget command} -setup {
+ spinbox .e
+} -body {
+ .e select adjust x
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad spinbox index "x"}
+test spinbox-3.56 {SpinboxWidgetCmd procedure, "selection adjust" widget command} -setup {
+ spinbox .e
+} -body {
+ .e select adjust 2 3
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection adjust index"}
+test spinbox-3.57 {SpinboxWidgetCmd procedure, "selection adjust" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
.e insert end "0123456789"
.e select from 1
.e select to 5
update
.e select adjust 4
selection get
-} {123}
-test spinbox-3.58 {SpinboxWidgetCmd procedure, "selection adjust" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {123}
+test spinbox-3.58 {SpinboxWidgetCmd procedure, "selection adjust" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
.e insert end "0123456789"
.e select from 1
.e select to 5
update
.e select adjust 2
selection get
-} {234}
-test spinbox-3.59 {SpinboxWidgetCmd procedure, "selection from" widget command} {
- list [catch {.e select from 2 3} msg] $msg
-} {1 {wrong # args: should be ".e selection from index"}}
-test spinbox-3.60 {SpinboxWidgetCmd procedure, "selection range" widget command} {
- list [catch {.e select range 2} msg] $msg
-} {1 {wrong # args: should be ".e selection range start end"}}
-test spinbox-3.61 {SpinboxWidgetCmd procedure, "selection range" widget command} {
- list [catch {.e selection range 2 3 4} msg] $msg
-} {1 {wrong # args: should be ".e selection range start end"}}
-test spinbox-3.62 {SpinboxWidgetCmd procedure, "selection range" widget command} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {234}
+test spinbox-3.59 {SpinboxWidgetCmd procedure, "selection from" widget command} -setup {
+ spinbox .e
+} -body {
+ .e select from 2 3
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection from index"}
+
+test spinbox-3.60 {SpinboxWidgetCmd procedure, "selection range" widget command} -setup {
+ spinbox .e
+} -body {
+ .e select range 2
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection range start end"}
+test spinbox-3.61 {SpinboxWidgetCmd procedure, "selection range" widget command} -setup {
+ spinbox .e
+} -body {
+ .e selection range 2 3 4
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection range start end"}
+test spinbox-3.62 {SpinboxWidgetCmd procedure, "selection range" widget command} -setup {
+ spinbox .e
+} -body {
.e insert end 0123456789
.e select from 1
.e select to 5
.e select range 4 4
- list [catch {.e index sel.first} msg] $msg
-} {1 {selection isn't in widget .e}}
-test spinbox-3.63 {SpinboxWidgetCmd procedure, "selection range" widget command} {
- .e delete 0 end
+ .e index sel.first
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {selection isn't in widget .e}
+test spinbox-3.63 {SpinboxWidgetCmd procedure, "selection range" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
.e insert end 0123456789
.e select from 3
.e select to 7
.e select range 2 9
list [.e index sel.first] [.e index sel.last] [.e index anchor]
-} {2 9 3}
-.e delete 0 end
-.e insert end "This is quite a long text string, so long that it "
-.e insert end "runs off the end of the window quite a bit."
-test spinbox-3.64 {SpinboxWidgetCmd procedure, "selection to" widget command} {
- list [catch {.e select to 2 3} msg] $msg
-} {1 {wrong # args: should be ".e selection to index"}}
-test spinbox-3.65 {SpinboxWidgetCmd procedure, "xview" widget command} {
+} -cleanup {
+ destroy .e
+} -result {2 9 3}
+test spinbox-3.64 {SpinboxWidgetCmd procedure, "selection to" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+ .e insert end "This is quite a long text string, so long that it "
+ .e insert end "runs off the end of the window quite a bit."
+} -body {
+ .e select to 2 3
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e selection to index"}
+test spinbox-3.64.1 {SpinboxWidgetCmd procedure, "selection" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e insert end 0123456789
+ .e selection range 0 end
+ .e configure -state disabled
+ .e selection range 2 4
+ .e configure -state normal
+ list [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {0 10}
+test spinbox-3.64.2 {SpinboxWidgetCmd procedure, "selection" widget command} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e insert end 0123456789
+ .e selection range 0 end
+ .e configure -state readonly
+ .e selection range 2 4
+ .e configure -state normal
+ list [.e index sel.first] [.e index sel.last]
+} -cleanup {
+ destroy .e
+} -result {2 4}
+
+test spinbox-3.65 {SpinboxWidgetCmd procedure, "xview" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e insert end "This is quite a long text string, so long that it "
+ .e insert end "runs off the end of the window quite a bit."
.e xview 5
format {%.6f %.6f} {*}[.e xview]
-} {0.053763 0.268817}
-test spinbox-3.66 {SpinboxWidgetCmd procedure, "xview" widget command} {
- list [catch {.e xview gorp} msg] $msg
-} {1 {bad spinbox index "gorp"}}
-test spinbox-3.67 {SpinboxWidgetCmd procedure, "xview" widget command} {
+} -cleanup {
+ destroy .e
+} -result {0.053763 0.268817}
+test spinbox-3.66 {SpinboxWidgetCmd procedure, "xview" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e xview gorp
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad spinbox index "gorp"}
+test spinbox-3.67 {SpinboxWidgetCmd procedure, "xview" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e insert end "This is quite a long text string, so long that it "
+ .e insert end "runs off the end of the window quite a bit."
.e xview 0
.e icursor 10
.e xview insert
format {%.6f %.6f} {*}[.e xview]
-} {0.107527 0.322581}
-test spinbox-3.68 {SpinboxWidgetCmd procedure, "xview" widget command} {
- list [catch {.e xview moveto foo bar} msg] $msg
-} {1 {wrong # args: should be ".e xview moveto fraction"}}
-test spinbox-3.69 {SpinboxWidgetCmd procedure, "xview" widget command} {
- list [catch {.e xview moveto foo} msg] $msg
-} {1 {expected floating-point number but got "foo"}}
-test spinbox-3.70 {SpinboxWidgetCmd procedure, "xview" widget command} {
+} -cleanup {
+ destroy .e
+} -result {0.107527 0.322581}
+test spinbox-3.68 {SpinboxWidgetCmd procedure, "xview" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e xview moveto foo bar
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {wrong # args: should be ".e xview moveto fraction"}
+test spinbox-3.69 {SpinboxWidgetCmd procedure, "xview" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e xview moveto foo
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {expected floating-point number but got "foo"}
+test spinbox-3.70 {SpinboxWidgetCmd procedure, "xview" widget command} -setup {
+ spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .e
+ update
+} -body {
+ .e insert end "This is quite a long text string, so long that it "
+ .e insert end "runs off the end of the window quite a bit."
.e xview moveto 0.5
format {%.6f %.6f} {*}[.e xview]
-} {0.505376 0.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]
+# Testing:
+ selection clear .e
+ .e index sel.first
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {selection isn't in widget .e}
+
+test spinbox-13.11 {GetSpinboxIndex procedure} -constraints win -body {
+# On mac and pc, when selection is cleared, spinbox widget remembers
+# last selected range. When selection ownership is restored to
+# spinbox, the old range will be rehighlighted.
+# Previous settings:
+ spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+# Testing:
+ selection clear .e
+ catch {selection get}
+ .e index sel.first
+} -cleanup {
+ destroy .e
+} -result {1}
+
+test spinbox-13.12 {GetSpinboxIndex procedure} -constraints unix -body {
+# Previous settings:
+ spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+# Testing:
+ selection clear .e
+ .e index sbogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {selection isn't in widget .e}
+
+test spinbox-13.12.1 {GetSpinboxIndex procedure} -constraints unix -body {
+# Previous settings:
+ spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+# Testing:
+ selection clear .e
+ .e index bogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad spinbox index "bogus"}
+
+test spinbox-13.13 {GetSpinboxIndex procedure} -constraints win -body {
+# Previous settings:
+ spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+# Testing:
+ selection clear .e
+ .e index sbogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad spinbox index "sbogus"}
+
+test spinbox-13.14 {GetSpinboxIndex procedure} -constraints win -body {
+# On mac and pc, when selection is cleared, spinbox widget remembers
+# last selected range. When selection ownership is restored to
+# spinbox, the old range will be rehighlighted.
+# Previous settings:
+ spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e select from 1
+ .e select to 6
+ list [.e index sel.first] [.e index sel.last]
+# Testing:
+ selection clear .e
+ selection get
+} -cleanup {
+ destroy .e
+} -returnCodes error -match glob -result {*}
+
+test spinbox-13.14.1 {GetSpinboxIndex procedure} -constraints win -body {
+# On mac and pc, when selection is cleared, spinbox widget remembers
+# last selected range. When selection ownership is restored to
+# spinbox, the old range will be rehighlighted.
+# Previous settings:
+ spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
.e select from 1
.e select to 6
list [.e index sel.first] [.e index sel.last]
-} {1 6}
-selection clear .e
-test spinbox-13.10 {GetSpinboxIndex procedure} unix {
- # On unix, when selection is cleared, spinbox widget's internal
- # selection range is reset.
-
- list [catch {.e index sel.first} msg] $msg
-} {1 {selection isn't in widget .e}}
-test spinbox-13.11 {GetSpinboxIndex procedure} win {
- # On mac and pc, when selection is cleared, spinbox widget remembers
- # last selected range. When selection ownership is restored to
- # spinbox, the old range will be rehighlighted.
-
- list [catch {selection get}] [.e index sel.first]
-} {1 1}
-test spinbox-13.12 {GetSpinboxIndex procedure} unix {
- list [catch {.e index sbogus} msg] $msg
-} {1 {selection isn't in widget .e}}
-test spinbox-13.13 {GetSpinboxIndex procedure} win {
- list [catch {.e index sbogus} msg] $msg
-} {1 {bad spinbox index "sbogus"}}
-test spinbox-13.14 {GetSpinboxIndex procedure} win {
- list [catch {selection get}] [catch {.e index sbogus}]
-} {1 1}
-test spinbox-13.15 {GetSpinboxIndex procedure} {
- list [catch {.e index @xyz} msg] $msg
-} {1 {bad spinbox index "@xyz"}}
-test spinbox-13.16 {GetSpinboxIndex procedure} {fonts} {
+# Testing:
+ selection clear .e
+ catch {selection get}
+ .e index sbogus
+} -cleanup {
+ destroy .e
+} -returnCodes error -match glob -result {*}
+
+test spinbox-13.15 {GetSpinboxIndex procedure} -body {
+ spinbox .e
+ selection clear .e
+ .e index @xyz
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad spinbox index "@xyz"}
+
+test spinbox-13.16 {GetSpinboxIndex procedure} -constraints fonts -body {
+ spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
.e index @4
-} {4}
-test spinbox-13.17 {GetSpinboxIndex procedure} {fonts} {
+} -cleanup {
+ destroy .e
+} -result {4}
+test spinbox-13.17 {GetSpinboxIndex procedure} -constraints fonts -body {
+ spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
.e index @11
-} {4}
-test spinbox-13.18 {GetSpinboxIndex procedure} {fonts} {
+} -cleanup {
+ destroy .e
+} -result {4}
+test spinbox-13.18 {GetSpinboxIndex procedure} -constraints fonts -body {
+ spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
.e index @12
-} {5}
-test spinbox-13.19 {GetSpinboxIndex procedure} {fonts} {
- # 11 is the minimum button width
- .e index @[expr [winfo width .e] - 6 - 11]
-} {8}
-test spinbox-13.20 {GetSpinboxIndex procedure} {fonts} {
- .e index @[expr [winfo width .e] - 5]
-} {9}
-test spinbox-13.21 {GetSpinboxIndex procedure} {
+} -cleanup {
+ destroy .e
+} -result {5}
+test spinbox-13.19 {GetSpinboxIndex procedure} -constraints fonts -body {
+ spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e index @[expr {[winfo width .e] - 6-11}]
+} -cleanup {
+ destroy .e
+} -result {8}
+test spinbox-13.20 {GetSpinboxIndex procedure} -constraints fonts -body {
+ spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
+ .e index @[expr {[winfo width .e] - 5}]
+} -cleanup {
+ destroy .e
+} -result {9}
+test spinbox-13.21 {GetSpinboxIndex procedure} -body {
+ spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
.e index @1000
-} {9}
-test spinbox-13.22 {GetSpinboxIndex procedure} {
- list [catch {.e index 1xyz} msg] $msg
-} {1 {bad spinbox index "1xyz"}}
-test spinbox-13.23 {GetSpinboxIndex procedure} {
+} -cleanup {
+ destroy .e
+} -result {9}
+test spinbox-13.22 {GetSpinboxIndex procedure} -setup {
+ spinbox .e
+ pack .e
+ update
+} -body {
+ .e index 1xyz
+} -cleanup {
+ destroy .e
+} -returnCodes error -result {bad spinbox index "1xyz"}
+test spinbox-13.23 {GetSpinboxIndex procedure} -body {
+ spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
.e index -10
-} {0}
-test spinbox-13.24 {GetSpinboxIndex procedure} {
+} -cleanup {
+ destroy .e
+} -result {0}
+test spinbox-13.24 {GetSpinboxIndex procedure} -body {
+ spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
.e index 12
-} {12}
-test spinbox-13.25 {GetSpinboxIndex procedure} {
+} -cleanup {
+ destroy .e
+} -result {12}
+test spinbox-13.25 {GetSpinboxIndex procedure} -body {
+ spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \
+ -font {Courier -12}
+ pack .e
+ .e insert 0 012345678901234567890
+ .e xview 4
+ update
.e index 49
-} {21}
+} -cleanup {
+ destroy .e
+} -result {21}
# XXX Still need to write tests for SpinboxScanTo and SpinboxSelectTo.
-set x {}
-for {set i 1} {$i <= 500} {incr i} {
- append x "This is line $i, out of 500\n"
-}
-test spinbox-14.1 {SpinboxFetchSelection procedure} {
- catch {destroy .e}
+test spinbox-14.1 {SpinboxFetchSelection procedure} -body {
spinbox .e
.e insert end "This is a test string"
.e select from 1
.e select to 18
selection get
-} {his is a test str}
-test spinbox-14.3 {SpinboxFetchSelection procedure} {
- catch {destroy .e}
+} -cleanup {
+ destroy .e
+} -result {his is a test str}
+test spinbox-14.3 {SpinboxFetchSelection procedure} -setup {
+ set x {}
+ for {set i 1} {$i <= 500} {incr i} {
+ append x "This is line $i, out of 500\n"
+}
+} -body {
spinbox .e
- .e insert end $x
+ .e insert end $x
.e select from 0
.e select to end
string compare [selection get] $x
-} 0
+} -cleanup {
+ destroy .e
+} -result {0}
-test spinbox-15.1 {SpinboxLostSelection} {
- catch {destroy .e}
+test spinbox-15.1 {SpinboxLostSelection} -body {
spinbox .e
.e insert 0 "Text"
.e select from 0
@@ -1222,265 +3136,546 @@ test spinbox-15.1 {SpinboxLostSelection} {
.e select from 0
.e select to 4
lappend result [selection get]
-} {Text Text}
-
-# No tests for EventuallyRedraw.
+} -cleanup {
+ destroy .e
+} -result {Text Text}
-catch {destroy .e}
-spinbox .e -width 10 -xscrollcommand scroll
-pack .e
-update
-test spinbox-16.1 {SpinboxVisibleRange procedure} {fonts} {
- .e delete 0 end
- .e insert 0 .............................
+test spinbox-16.1 {SpinboxVisibleRange procedure} -constraints fonts -body {
+ spinbox .e -width 10 -font {Helvetica -12}
+ pack .e
+ update
+ .e insert 0 "............................."
format {%.6f %.6f} {*}[.e xview]
-} {0.000000 0.827586}
-test spinbox-16.2 {SpinboxVisibleRange procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {0.000000 0.827586}
+test spinbox-16.2 {SpinboxVisibleRange procedure} -body {
+ spinbox .e
format {%.6f %.6f} {*}[.e xview]
-} {0.000000 1.000000}
+} -cleanup {
+ destroy .e
+} -result {0.000000 1.000000}
-catch {destroy .e}
-spinbox .e -width 10 -xscrollcommand scroll -font $fixed
-pack .e
-update
-test spinbox-17.1 {SpinboxUpdateScrollbar procedure} {
+
+test spinbox-17.1 {SpinboxUpdateScrollbar procedure} -body {
+ spinbox .e -width 10 -xscrollcommand scroll -font {Courier -12}
+ pack .e
.e delete 0 end
.e insert 0 123
update
format {%.6f %.6f} {*}$scrollInfo
-} {0.000000 1.000000}
-test spinbox-17.2 {SpinboxUpdateScrollbar procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {0.000000 1.000000}
+test spinbox-17.2 {SpinboxUpdateScrollbar procedure} -body {
+ spinbox .e -width 10 -xscrollcommand scroll -font {Courier -12}
+ pack .e
.e insert 0 0123456789abcdef
.e xview 3
update
format {%.6f %.6f} {*}$scrollInfo
-} {0.187500 0.812500}
-test spinbox-17.3 {SpinboxUpdateScrollbar procedure} {
- .e delete 0 end
+} -cleanup {
+ destroy .e
+} -result {0.187500 0.812500}
+test spinbox-17.3 {SpinboxUpdateScrollbar procedure} -body {
+ spinbox .e -width 10 -xscrollcommand scroll -font {Courier -12}
+ pack .e
.e insert 0 abcdefghijklmnopqrs
.e xview 6
update
format {%.6f %.6f} {*}$scrollInfo
-} {0.315789 0.842105}
-test spinbox-17.4 {SpinboxUpdateScrollbar procedure} {
+} -cleanup {
destroy .e
- set x "Background error did not happen"
+} -result {0.315789 0.842105}
+test spinbox-17.4 {SpinboxUpdateScrollbar procedure} -setup {
proc bgerror msg {
global x
set x $msg
- }
+}
+} -body {
spinbox .e -width 5 -xscrollcommand thisisnotacommand
pack .e
update
- rename bgerror {}
list $x $errorInfo
-} {{invalid command name "thisisnotacommand"} {invalid command name "thisisnotacommand"
+} -cleanup {
+ destroy .e
+ rename bgerror {}
+} -result {{invalid command name "thisisnotacommand"} {invalid command name "thisisnotacommand"
while executing
"thisisnotacommand 0.0 1.0"
(horizontal scrolling command executed by .e)}}
-set l [interp hidden]
-deleteWindows
-test spinbox-18.1 {Spinbox widget vs hiding} {
- destroy .e
+test spinbox-18.1 {Spinbox widget vs hiding} -setup {
spinbox .e
+} -body {
+ set l [interp hidden]
interp hide {} .e
destroy .e
- list [winfo children .] [interp hidden]
-} [list {} $l]
+ set res1 [list [winfo children .] [interp hidden]]
+ set res2 [list {} $l]
+ expr {$res1 == $res2}
+} -result {1}
##
## Spinbox widget VALIDATION tests
##
-
-destroy .e
-catch {unset ::e}
-catch {unset ::vVals}
-spinbox .e -validate all \
- -validatecommand [list doval %W %d %i %P %s %S %v %V] \
- -invalidcommand bell \
- -textvariable ::e \
- -background red -foreground white
-pack .e
-proc doval {W d i P s S v V} {
- set ::vVals [list $W $d $i $P $s $S $v $V]
- return 1
-}
-
# The validation tests build each one upon the previous, so cascading
# failures aren't good
#
-test spinbox-19.1 {spinbox widget validation} {
+# 19.* test cases in previous version highly depended on the previous
+# test cases. This was replaced by inserting recently set configurations
+# that matters for the test case
+test spinbox-19.1 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
.e insert 0 a
set ::vVals
-} {.e 1 0 a {} a all key}
-test spinbox-19.2 {spinbox widget validation} {
+} -cleanup {
+ destroy .e
+} -result {.e 1 0 a {} a all key}
+
+test spinbox-19.2 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert 0 a ;# previous settings
.e insert 1 b
set ::vVals
-} {.e 1 1 ab a b all key}
-test spinbox-19.3 {spinbox widget validation} {
+} -cleanup {
+ destroy .e
+} -result {.e 1 1 ab a b all key}
+
+test spinbox-19.3 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert 0 ab ;# previous settings
.e insert end c
set ::vVals
-} {.e 1 2 abc ab c all key}
-test spinbox-19.4 {spinbox widget validation} {
+} -cleanup {
+ destroy .e
+} -result {.e 1 2 abc ab c all key}
+
+test spinbox-19.4 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert 0 abc ;# previous settings
.e insert 1 123
list $::vVals $::e
-} {{.e 1 1 a123bc abc 123 all key} a123bc}
-test spinbox-19.5 {spinbox widget validation} {
+} -cleanup {
+ destroy .e
+} -result {{.e 1 1 a123bc abc 123 all key} a123bc}
+
+test spinbox-19.5 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert 0 a123bc ;# previous settings
.e delete 2
set ::vVals
-} {.e 0 2 a13bc a123bc 2 all key}
-test spinbox-19.6 {spinbox widget validation} {
+} -cleanup {
+ destroy .e
+} -result {.e 0 2 a13bc a123bc 2 all key}
+
+test spinbox-19.6 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert 0 a13bc ;# previous settings
.e configure -validate key
.e delete 1 3
set ::vVals
-} {.e 0 1 abc a13bc 13 key key}
-test spinbox-19.7 {spinbox widget validation} {
+} -cleanup {
+ destroy .e
+} -result {.e 0 1 abc a13bc 13 key key}
+
+test spinbox-19.7 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate focus \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abc ;# previous settings
set ::vVals {}
- .e configure -validate focus
.e insert end d
set ::vVals
-} {}
-test spinbox-19.8 {spinbox widget validation} {
+} -cleanup {
+ destroy .e
+} -result {}
+
+test spinbox-19.8 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e configure -validate focus ;# previous settings
+ .e insert end abcd ;# previous settings
focus -force .e
- # update necessary to process FocusIn event
+# update necessary to process FocusIn event
update
set ::vVals
-} {.e -1 -1 abcd abcd {} focus focusin}
-test spinbox-19.9 {spinbox widget validation} {
+} -cleanup {
+ destroy .e
+} -result {.e -1 -1 abcd abcd {} focus focusin}
+
+test spinbox-19.9 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate focus \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
+ focus -force .e ;# previous settings
+ update ;# previous settings
+# update necessary to process FocusIn event
focus -force .
- # update necessary to process FocusOut event
+# update necessary to process FocusOut event
update
set ::vVals
-} {.e -1 -1 abcd abcd {} focus focusout}
-.e configure -validate all
-test spinbox-19.10 {spinbox widget validation} {
+} -cleanup {
+ destroy .e
+} -result {.e -1 -1 abcd abcd {} focus focusout}
+
+test spinbox-19.10 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
focus -force .e
- # update necessary to process FocusIn event
+# update necessary to process FocusIn event
update
set ::vVals
-} {.e -1 -1 abcd abcd {} all focusin}
-test spinbox-19.11 {spinbox widget validation} {
+} -cleanup {
+ destroy .e
+} -result {.e -1 -1 abcd abcd {} all focusin}
+
+test spinbox-19.11 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
+ focus -force .e ;# previous settings
+# update necessary to process FocusIn event
+ update ;# previous settings
focus -force .
- # update necessary to process FocusOut event
+# update necessary to process FocusOut event
update
set ::vVals
-} {.e -1 -1 abcd abcd {} all focusout}
-.e configure -validate focusin
-test spinbox-19.12 {spinbox widget validation} {
+} -cleanup {
+ destroy .e
+} -result {.e -1 -1 abcd abcd {} all focusout}
+
+test spinbox-19.12 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate focusin \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert 0 abcd ;# previous settings
focus -force .e
- # update necessary to process FocusIn event
+# update necessary to process FocusIn event
update
set ::vVals
-} {.e -1 -1 abcd abcd {} focusin focusin}
-test spinbox-19.13 {spinbox widget validation} {
+} -cleanup {
+ destroy .e
+} -result {.e -1 -1 abcd abcd {} focusin focusin}
+
+test spinbox-19.13 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate focusin \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
set ::vVals {}
focus -force .
- # update necessary to process FocusOut event
+# update necessary to process FocusOut event
update
set ::vVals
-} {}
-.e configure -validate focuso
-test spinbox-19.14 {spinbox widget validation} {
+} -cleanup {
+ destroy .e
+} -result {}
+
+test spinbox-19.14 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate focuso \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
+ set ::vVals {} ;# previous settings
focus -force .e
- # update necessary to process FocusIn event
+# update necessary to process FocusIn event
update
set ::vVals
-} {}
-test spinbox-19.15 {spinbox widget validation} {
+} -cleanup {
+ destroy .e
+} -result {}
+
+test spinbox-19.15 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate focuso \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
+ set ::vVals {} ;# previous settings
+ focus -force .e ;# previous settings
+# update necessary to process FocusIn event
+ update ;# previous settings
focus -force .
- # update necessary to process FocusOut event
+# update necessary to process FocusOut event
update
set ::vVals
-} {.e -1 -1 abcd abcd {} focusout focusout}
-test spinbox-19.16 {spinbox widget validation} {
+} -cleanup {
+ destroy .e
+} -result {.e -1 -1 abcd abcd {} focusout focusout}
+
+# the same as 19.16 but added [.e validate] to returned list
+test spinbox-19.16 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate focuso \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
+ set ::vVals {} ;# previous settings
+ focus -force .e ;# previous settings
+# update necessary to process FocusIn event
+ update ;# previous settings
+ focus -force .
+# update necessary to process FocusOut event
+ update
list [.e validate] $::vVals
-} {1 {.e -1 -1 abcd abcd {} all forced}}
-test spinbox-19.17 {spinbox widget validation} {
+} -cleanup {
+ destroy .e
+} -result {1 {.e -1 -1 abcd abcd {} all forced}}
+
+
+test spinbox-19.17 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate focuso \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ .e insert end abcd ;# previous settings
set ::e newdata
list [.e cget -validate] $::vVals
-} {focusout {.e -1 -1 newdata abcd {} focusout forced}}
+} -cleanup {
+ destroy .e
+} -result {focusout {.e -1 -1 newdata abcd {} focusout forced}}
-proc doval {W d i P s S v V} {
- set ::vVals [list $W $d $i $P $s $S $v $V]
- return 0
-}
-.e configure -validate all
-test spinbox-19.18 {spinbox widget validation} {
+# proc doval changed - returns 0
+test spinbox-19.18 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate all \
+ -validatecommand [list doval3 %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ set ::e newdata ;# previous settings
+ .e configure -validate all
set ::e nextdata
list [.e cget -validate] $::vVals
-} {none {.e -1 -1 nextdata newdata {} all forced}}
+} -cleanup {
+ destroy .e
+} -result {none {.e -1 -1 nextdata newdata {} all forced}}
-proc doval {W d i P s S v V} {
- set ::vVals [list $W $d $i $P $s $S $v $V]
- set ::e mydata
- return 1
-}
-.e configure -validate all
## This sets validate to none because it shows that we prevent a possible
## loop condition in the validation, when the spinbox textvar is also set
-test spinbox-19.19 {spinbox widget validation} {
+# proc doval2 used
+test spinbox-19.19 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate all \
+ -validatecommand [list doval3 %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ set ::e nextdata ;# previous settings
+
+ .e configure -validatecommand [list doval2 %W %d %i %P %s %S %v %V]
.e validate
list [.e cget -validate] [.e get] $::vVals
-} {none mydata {.e -1 -1 nextdata nextdata {} all forced}}
-
-.e configure -validate all
+} -cleanup {
+ destroy .e
+} -result {none mydata {.e -1 -1 nextdata nextdata {} all forced}}
## This leaves validate alone because we trigger validation through the
## textvar (a write trace), and the write during validation triggers
## nothing (by definition of avoiding loops on var traces). This is
## one of those "dangerous" conditions where the user will have a
## different value in the spinbox widget shown as is in the textvar.
-test spinbox-19.20 {spinbox widget validation} {
+test spinbox-19.20 {spinbox widget validation} -setup {
+ unset -nocomplain ::e ::vVals
+} -body {
+ spinbox .e -validate all \
+ -validatecommand [list doval %W %d %i %P %s %S %v %V] \
+ -invalidcommand bell \
+ -textvariable ::e \
+ -background red -foreground white
+ pack .e
+ set ::e nextdata ;# previous settings
+ .e configure -validatecommand [list doval2 %W %d %i %P %s %S %v %V] ;# prev
+ .e validate ;# previous settings
+
+ .e configure -validate all
set ::e testdata
list [.e cget -validate] [.e get] $::e $::vVals
-} {all testdata mydata {.e -1 -1 testdata mydata {} all forced}}
+} -cleanup {
+ destroy .e
+} -result {all testdata mydata {.e -1 -1 testdata mydata {} all forced}}
+##
+## End validation tests
+##
-# A format specifier is allowed to be of the form %[-+ 0]{0,1}\d.?\d?f
-#
-destroy .e
-spinbox .e
-test spinbox-20.1 {spinbox config, -format specifier} {
- list [catch {.e config -format %2f} msg] $msg
-} {0 {}}
-test spinbox-20.2 {spinbox config, -format specifier} {
- list [catch {.e config -format %2.2f} msg] $msg
-} {0 {}}
-test spinbox-20.3 {spinbox config, -format specifier} {
- list [catch {.e config -format %.2f} msg] $msg
-} {0 {}}
-test spinbox-20.4 {spinbox config, -format specifier} {
- list [catch {.e config -format %2.f} msg] $msg
-} {0 {}}
-test spinbox-20.5 {spinbox config, -format specifier} {
- list [catch {.e config -format %2e-1f} msg] $msg
-} {1 {bad spinbox format specifier "%2e-1f"}}
-test spinbox-20.6 {spinbox config, -format specifier} {
- list [catch {.e config -format 2.2} msg] $msg
-} {1 {bad spinbox format specifier "2.2"}}
-test spinbox-20.7 {spinbox config, -format specifier} {
- list [catch {.e config -format %2.-2f} msg] $msg
-} {1 {bad spinbox format specifier "%2.-2f"}}
-test spinbox-20.8 {spinbox config, -format specifier} {
- list [catch {.e config -format %-2.02f} msg] $msg
-} {0 {}}
-test spinbox-20.9 {spinbox config, -format specifier} {
- list [catch {.e config -format "% 2.02f"} msg] $msg
-} {0 {}}
-test spinbox-20.10 {spinbox config, -format specifier} {
- list [catch {.e config -format "% -2.200f"} msg] $msg
-} {0 {}}
-test spinbox-20.11 {spinbox config, -format specifier} {
- list [catch {.e config -format "%09.200f"} msg] $msg
-} {0 {}}
-test spinbox-20.12 {spinbox config, -format specifier does something} {
+test spinbox-20.1 {spinbox config, -format specifier} -body {
+ spinbox .e
+ .e config -format %2f
+} -cleanup {
+ destroy .e
+} -returnCodes ok
+test spinbox-20.2 {spinbox config, -format specifier} -body {
+ spinbox .e
+ .e config -format %2.2f
+} -cleanup {
+ destroy .e
+} -returnCodes ok
+test spinbox-20.3 {spinbox config, -format specifier} -body {
+ spinbox .e
+ .e config -format %.2f
+} -cleanup {
+ destroy .e
+} -returnCodes ok
+test spinbox-20.4 {spinbox config, -format specifier} -body {
+ spinbox .e
+ .e config -format %2.f
+} -cleanup {
+ destroy .e
+} -returnCodes ok
+test spinbox-20.5 {spinbox config, -format specifier} -body {
+ spinbox .e
+ .e config -format %2e-1f
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad spinbox format specifier "%2e-1f"}
+test spinbox-20.6 {spinbox config, -format specifier} -body {
+ spinbox .e
+ .e config -format 2.2
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad spinbox format specifier "2.2"}
+test spinbox-20.7 {spinbox config, -format specifier} -body {
+ spinbox .e
+ .e config -format %2.-2f
+} -cleanup {
+ destroy .e
+} -returnCodes {error} -result {bad spinbox format specifier "%2.-2f"}
+test spinbox-20.8 {spinbox config, -format specifier} -body {
+ spinbox .e
+ .e config -format %-2.02f
+} -cleanup {
+ destroy .e
+} -returnCodes ok
+test spinbox-20.9 {spinbox config, -format specifier} -body {
+ spinbox .e
+ .e config -format "% 2.02f"
+} -cleanup {
+ destroy .e
+} -returnCodes ok
+test spinbox-20.10 {spinbox config, -format specifier} -body {
+ spinbox .e
+ .e config -format "% -2.200f"
+} -cleanup {
+ destroy .e
+} -returnCodes ok
+test spinbox-20.11 {spinbox config, -format specifier} -body {
+ spinbox .e
+ .e config -format "%09.200f"
+} -cleanup {
+ destroy .e
+} -returnCodes ok
+test spinbox-20.12 {spinbox config, -format specifier does something} -setup {
+ spinbox .e
set out {}
+} -body {
.e config -format "%02.f"
.e config -values {} -from 0 -to 10 -increment 1
lappend out [.e set 0]; # set currently doesn't force format
@@ -1489,10 +3684,12 @@ test spinbox-20.12 {spinbox config, -format specifier does something} {
lappend out [.e set 3]; # set currently doesn't force format
.e config -format "%03.f"
lappend out [.e set]; # changing -format should cause formatting
-} {0 01 3 003}
-
-test spinbox-21.1 {spinbox button, out of range checking} {
+} -cleanup {
destroy .e
+} -result {0 01 3 003}
+
+
+test spinbox-21.1 {spinbox button, out of range checking} -body {
spinbox .e -from -10 -to 20 -increment 2
set out {}
lappend out [.e get]; # -10
@@ -1550,50 +3747,60 @@ test spinbox-21.1 {spinbox button, out of range checking} {
lappend out [.e get]; # 18
.e invoke buttonup; # no wrap
lappend out [.e get]; # 20
+} -cleanup {
+ destroy .e
+} -result {-10 20 20 -10 -10 -10 20 20 18 -10 -10 -8 -10 -8 -10 20 18 20}
-} {-10 20 20 -10 -10 -10 20 20 18 -10 -10 -8 -10 -8 -10 20 18 20}
-
-test spinbox-22.1 {spinbox config, -from changes SF bug 559078} {
+test spinbox-22.1 {spinbox config, -from changes SF bug 559078} -body {
set val 5
- destroy .s
- spinbox .s -from 1 -to 10 -textvariable val
+ spinbox .e -from 1 -to 10 -textvariable val
set val
-} {5}
-test spinbox-22.2 {spinbox config, -from changes SF bug 559078} {
- .s configure -from 3 -to 10
+} -cleanup {
+ destroy .e
+} -result {5}
+test spinbox-22.2 {spinbox config, -from changes SF bug 559078} -body {
+ set val 5
+ spinbox .e -from 1 -to 10 -textvariable val
+ .e configure -from 3 -to 10
set val
-} {5}
-test spinbox-22.3 {spinbox config, -from changes SF bug 559078} {
- .s configure -from 6 -to 10
+} -cleanup {
+ destroy .e
+} -result {5}
+test spinbox-22.3 {spinbox config, -from changes SF bug 559078} -body {
+ set val 5
+ spinbox .e -from 3 -to 10 -textvariable val
+ .e configure -from 6 -to 10
set val
-} {6}
-
-test entry-23.1 {selection present while disabled, bug 637828} {
+} -cleanup {
destroy .e
- entry .e
+} -result {6}
+
+test spinbox-23.1 {selection present while disabled, bug 637828} -body {
+ spinbox .e
.e insert end 0123456789
.e select from 3
.e select to 6
set out [.e selection present]
.e configure -state disabled
- # still return 1 when disabled, because 'selection get' will work,
- # but selection cannot be changed (new behavior since 8.4)
+# still return 1 when disabled, because 'selection get' will work,
+# but selection cannot be changed (new behavior since 8.4)
.e select to 9
lappend out [.e selection present] [selection get]
-} {1 1 345}
+} -cleanup {
+ destroy .e
+} -result {1 1 345}
-destroy .e
-catch {unset ::e ::vVals}
-
-##
-## End validation tests
-##
+# Collected comments about lacks from the test
# XXX Still need to write tests for SpinboxBlinkProc, SpinboxFocusProc,
# and SpinboxTextVarProc.
+# No tests for DisplaySpinbox.
+# XXX Still need to write tests for SpinboxScanTo and SpinboxSelectTo.
+# No tests for EventuallyRedraw
-option clear
-
+# option clear
# cleanup
cleanupTests
return
+
+
diff --git a/tests/text.test b/tests/text.test
index 52689ba..5089bb1 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}
+
+
+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}
+
-entry .t.e
-.t.e insert end abcdefg
-.t.e select from 0
+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}
-.t insert 1.0 "Line 1
+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,17 +2630,17 @@ 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 2 5}
-# 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] \
@@ -717,23 +2649,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]
@@ -742,11 +2693,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]
@@ -755,11 +2714,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
@@ -772,10 +2739,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
@@ -787,11 +2761,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]
@@ -806,10 +2787,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
@@ -830,225 +2815,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 {}
@@ -1056,265 +3226,363 @@ test text-14.1 {TextEventProc procedure} {
lappend x [.tx2 cget -bg]
destroy .tx1
lappend x [info command .tx*] [winfo exists .tx1] [winfo exists .tx2]
-} {1 #543210 {} 0 0}
+} -cleanup {
+ destroy .txt1
+} -result {1 #543210 {} 0 0}
+
-test text-15.1 {TextCmdDeletedProc procedure} {
+test text-17.1 {TextCmdDeletedProc procedure} -body {
text .tx1
rename .tx1 {}
list [info command .tx*] [winfo exists .tx1]
-} {{} 0}
-test text-15.2 {TextCmdDeletedProc procedure, disabling -setgrid} fonts {
- catch {destroy .top}
- toplevel .top
- wm geom .top +0+0
- text .top.t -setgrid 1 -width 20 -height 10
- pack .top.t
- update
- set x [wm geometry .top]
- rename .top.t {}
- update
- lappend x [wm geometry .top]
+} -cleanup {
+ destroy .txt1
+} -result {{} 0}
+test text-17.2 {TextCmdDeletedProc procedure, disabling -setgrid} -constraints {
+ fonts
+} -body {
+ toplevel .top
+ text .top.t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} \
+ -setgrid 1 -width 20 -height 10
+ pack .top.t
+ update
+ set geom [wm geometry .top]
+ set x [string range $geom 0 [string first + $geom]]
+ rename .top.t {}
+ update
+ set geom [wm geometry .top]
+ lappend x [string range $geom 0 [string first + $geom]]
+ return $x
+} -cleanup {
destroy .top
- set x
-} {20x10+0+0 150x140+0+0}
+} -result {20x10+ 150x140+}
-test text-16.1 {InsertChars procedure} {
- catch {destroy .t2}
- text .t2
- .t2 insert 2.0 abcd\n
- .t2 get 1.0 end
-} {abcd
+
+test text-18.1 {InsertChars procedure} -body {
+ text .t
+ .t insert 2.0 abcd\n
+ .t get 1.0 end
+} -cleanup {
+ destroy .t
+} -result {abcd
}
-test text-16.2 {InsertChars procedure} {
- catch {destroy .t2}
- text .t2
- .t2 insert 1.0 abcd\n
- .t2 insert end 123\n
- .t2 get 1.0 end
-} {abcd
+test text-18.2 {InsertChars procedure} -body {
+ text .t
+ .t insert 1.0 abcd\n
+ .t insert end 123\n
+ .t get 1.0 end
+} -cleanup {
+ destroy .t
+} -result {abcd
123
}
-test text-16.3 {InsertChars procedure} {
- catch {destroy .t2}
- text .t2
- .t2 insert 1.0 abcd\n
- .t2 insert 10.0 123
- .t2 get 1.0 end
-} {abcd
+test text-18.3 {InsertChars procedure} -body {
+ text .t
+ .t insert 1.0 abcd\n
+ .t insert 10.0 123
+ .t get 1.0 end
+} -cleanup {
+ destroy .t
+} -result {abcd
123
}
-test text-16.4 {InsertChars procedure, inserting on top visible line} {
- catch {destroy .t2}
- text .t2 -width 20 -height 4 -wrap word
- pack .t2
- .t2 insert insert "Now is the time for all great men to come to the "
- .t2 insert insert "aid of their party.\n"
- .t2 insert insert "Now is the time for all great men.\n"
- .t2 see end
- update
- .t2 insert 1.0 "Short\n"
- .t2 index @0,0
-} {2.56}
-test text-16.5 {InsertChars procedure, inserting on top visible line} {
- catch {destroy .t2}
- text .t2 -width 20 -height 4 -wrap word
- pack .t2
- .t2 insert insert "Now is the time for all great men to come to the "
- .t2 insert insert "aid of their party.\n"
- .t2 insert insert "Now is the time for all great men.\n"
- .t2 see end
- update
- .t2 insert 1.55 "Short\n"
- .t2 index @0,0
-} {2.0}
-test text-16.6 {InsertChars procedure, inserting on top visible line} {
- catch {destroy .t2}
- text .t2 -width 20 -height 4 -wrap word
- pack .t2
- .t2 insert insert "Now is the time for all great men to come to the "
- .t2 insert insert "aid of their party.\n"
- .t2 insert insert "Now is the time for all great men.\n"
- .t2 see end
- update
- .t2 insert 1.56 "Short\n"
- .t2 index @0,0
-} {1.56}
-test text-16.7 {InsertChars procedure, inserting on top visible line} {
- catch {destroy .t2}
- text .t2 -width 20 -height 4 -wrap word
- pack .t2
- .t2 insert insert "Now is the time for all great men to come to the "
- .t2 insert insert "aid of their party.\n"
- .t2 insert insert "Now is the time for all great men.\n"
- .t2 see end
- update
- .t2 insert 1.57 "Short\n"
- .t2 index @0,0
-} {1.56}
-catch {destroy .t2}
-
-proc setup {} {
- .t delete 1.0 end
+test text-18.4 {InsertChars procedure, inserting on top visible line} -setup {
+ text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .t
+} -body {
+ .t configure -width 20 -height 4 -wrap word
+ .t insert insert "Now is the time for all great men to come to the "
+ .t insert insert "aid of their party.\n"
+ .t insert insert "Now is the time for all great men.\n"
+ .t see end
+ update
+ .t insert 1.0 "Short\n"
+ .t index @0,0
+} -cleanup {
+ destroy .t
+} -result {2.56}
+test text-18.5 {InsertChars procedure, inserting on top visible line} -setup {
+ text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .t
+} -body {
+ .t configure -width 20 -height 4 -wrap word
+ .t insert insert "Now is the time for all great men to come to the "
+ .t insert insert "aid of their party.\n"
+ .t insert insert "Now is the time for all great men.\n"
+ .t see end
+ update
+ .t insert 1.55 "Short\n"
+ .t index @0,0
+} -cleanup {
+ destroy .t
+} -result {2.0}
+test text-18.6 {InsertChars procedure, inserting on top visible line} -setup {
+ text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .t
+} -body {
+ .t configure -width 20 -height 4 -wrap word
+ .t insert insert "Now is the time for all great men to come to the "
+ .t insert insert "aid of their party.\n"
+ .t insert insert "Now is the time for all great men.\n"
+ .t see end
+ update
+ .t insert 1.56 "Short\n"
+ .t index @0,0
+} -cleanup {
+ destroy .t
+} -result {1.56}
+test text-18.7 {InsertChars procedure, inserting on top visible line} -setup {
+ text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2
+ pack .t
+} -body {
+ .t configure -width 20 -height 4 -wrap word
+ .t insert insert "Now is the time for all great men to come to the "
+ .t insert insert "aid of their party.\n"
+ .t insert insert "Now is the time for all great men.\n"
+ .t see end
+ update
+ .t insert 1.57 "Short\n"
+ .t index @0,0
+} -cleanup {
+ destroy .t
+} -result {1.56}
+
+
+test text-19.1 {DeleteChars procedure} -body {
+ text .t
+ .t get 1.0 end
+} -cleanup {
+ destroy .t
+} -result {
+}
+test text-19.2 {DeleteChars procedure} -body {
+ text .t
+ .t delete foobar
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad text index "foobar"}
+test text-19.3 {DeleteChars procedure} -body {
+ text .t
+ .t delete 1.0 lousy
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad text index "lousy"}
+test text-19.4 {DeleteChars procedure} -body {
+ text .t
.t insert 1.0 "Line 1
abcde
12345
Line 4"
-}
-
-.t delete 1.0 end
-test text-17.1 {DeleteChars procedure} {
- .t get 1.0 end
-} {
-}
-test text-17.2 {DeleteChars procedure} {
- list [catch {.t delete foobar} msg] $msg
-} {1 {bad text index "foobar"}}
-test text-17.3 {DeleteChars procedure} {
- list [catch {.t delete 1.0 lousy} msg] $msg
-} {1 {bad text index "lousy"}}
-test text-17.4 {DeleteChars procedure} {
- setup
.t delete 2.1
.t get 1.0 end
-} {Line 1
+} -cleanup {
+ destroy .t
+} -result {Line 1
acde
12345
Line 4
}
-test text-17.5 {DeleteChars procedure} {
- setup
+test text-19.5 {DeleteChars procedure} -body {
+ text .t
+ .t insert 1.0 "Line 1
+abcde
+12345
+Line 4"
.t delete 2.3
.t get 1.0 end
-} {Line 1
+} -cleanup {
+ destroy .t
+} -result {Line 1
abce
12345
Line 4
}
-test text-17.6 {DeleteChars procedure} {
- setup
+test text-19.6 {DeleteChars procedure} -body {
+ text .t
+ .t insert 1.0 "Line 1
+abcde
+12345
+Line 4"
.t delete 2.end
.t get 1.0 end
-} {Line 1
+} -cleanup {
+ destroy .t
+} -result {Line 1
abcde12345
Line 4
}
-test text-17.7 {DeleteChars procedure} {
- setup
+test text-19.7 {DeleteChars procedure} -body {
+ text .t
+ .t insert 1.0 "Line 1
+abcde
+12345
+Line 4"
.t tag add sel 4.2 end
.t delete 4.2 end
list [.t tag ranges sel] [.t get 1.0 end]
-} {{} {Line 1
+} -cleanup {
+ destroy .t
+} -result {{} {Line 1
abcde
12345
Li
}}
-test text-17.8 {DeleteChars procedure} {
- setup
+test text-19.8 {DeleteChars procedure} -body {
+ text .t
+ .t insert 1.0 "Line 1
+abcde
+12345
+Line 4"
.t tag add sel 1.0 end
.t delete 4.0 end
list [.t tag ranges sel] [.t get 1.0 end]
-} {{1.0 3.5} {Line 1
+} -cleanup {
+ destroy .t
+} -result {{1.0 3.5} {Line 1
abcde
12345
}}
-test text-17.9 {DeleteChars procedure} {
- setup
+test text-19.9 {DeleteChars procedure} -body {
+ text .t
+ .t insert 1.0 "Line 1
+abcde
+12345
+Line 4"
.t delete 2.2 2.2
.t get 1.0 end
-} {Line 1
+} -cleanup {
+ destroy .t
+} -result {Line 1
abcde
12345
Line 4
}
-test text-17.10 {DeleteChars procedure} {
- setup
+test text-19.10 {DeleteChars procedure} -body {
+ text .t
+ .t insert 1.0 "Line 1
+abcde
+12345
+Line 4"
.t delete 2.3 2.1
.t get 1.0 end
-} {Line 1
+} -cleanup {
+ destroy .t
+} -result {Line 1
abcde
12345
Line 4
}
-test text-17.11 {DeleteChars procedure} {
- catch {destroy .t2}
- toplevel .t2
- text .t2.t -width 20 -height 5
- pack append .t2 .t2.t top
- wm geometry .t2 +0+0
- .t2.t insert 1.0 "abc\n123\nx\ny\nz\nq\nr\ns"
- update
- .t2.t delete 1.0 3.0
- list [.t2.t index @0,0] [.t2.t get @0,0]
-} {1.0 x}
-test text-17.12 {DeleteChars procedure} {
- catch {destroy .t2}
- toplevel .t2
- text .t2.t -width 20 -height 5
- pack append .t2 .t2.t top
- wm geometry .t2 +0+0
- .t2.t insert 1.0 "abc\n123\nx\ny\nz\nq\nr\ns"
- .t2.t yview 3.0
- update
- .t2.t delete 2.0 4.0
- list [.t2.t index @0,0] [.t2.t get @0,0]
-} {2.0 y}
-catch {destroy .t2}
-toplevel .t2
-text .t2.t -width 1 -height 10 -wrap char
-frame .t2.f -width 200 -height 20 -relief raised -bd 2
-pack .t2.f .t2.t -side left
-wm geometry .t2 +0+0
-update
-test text-17.13 {DeleteChars procedure, updates affecting topIndex} {
- .t2.t delete 1.0 end
- .t2.t insert end "abcde\n12345\nqrstuv"
- .t2.t yview 2.1
- .t2.t delete 1.4 2.3
- .t2.t index @0,0
-} {1.2}
-test text-17.14 {DeleteChars procedure, updates affecting topIndex} {
- .t2.t delete 1.0 end
- .t2.t insert end "abcde\n12345\nqrstuv"
- .t2.t yview 2.1
- .t2.t delete 2.3 2.4
- .t2.t index @0,0
-} {2.0}
-test text-17.15 {DeleteChars procedure, updates affecting topIndex} {
- .t2.t delete 1.0 end
- .t2.t insert end "abcde\n12345\nqrstuv"
- .t2.t yview 1.3
- .t2.t delete 1.0 1.2
- .t2.t index @0,0
-} {1.1}
-test text-17.16 {DeleteChars procedure, updates affecting topIndex} {
- catch {destroy .t2}
- toplevel .t2
- text .t2.t -width 6 -height 10 -wrap word
- frame .t2.f -width 200 -height 20 -relief raised -bd 2
- pack .t2.f .t2.t -side left
- wm geometry .t2 +0+0
- update
- .t2.t insert end "abc def\n01 2345 678 9101112\nLine 3\nLine 4\nLine 5\n6\n7\n8\n"
- .t2.t yview 2.4
- .t2.t delete 2.5
- set x [.t2.t index @0,0]
- .t2.t delete 2.5
- list $x [.t2.t index @0,0]
-} {2.3 2.0}
-
-.t delete 1.0 end
-foreach i {a b c d e f g h i j k l m n o p q r s t u v w x y z} {
- .t insert end $i.0$i.1$i.2$i.3$i.4\n
-}
-test text-18.1 {TextFetchSelection procedure} {
+test text-19.11 {DeleteChars procedure} -body {
+ toplevel .top
+ text .top.t -width 20 -height 5
+ pack append .top .top.t top
+ wm geometry .top +0+0
+ .top.t insert 1.0 "abc\n123\nx\ny\nz\nq\nr\ns"
+ update
+ .top.t delete 1.0 3.0
+ list [.top.t index @0,0] [.top.t get @0,0]
+} -cleanup {
+ destroy .top
+} -result {1.0 x}
+test text-19.12 {DeleteChars procedure} -body {
+ toplevel .top
+ text .top.t -width 20 -height 5
+ pack append .top .top.t top
+ wm geometry .top +0+0
+ .top.t insert 1.0 "abc\n123\nx\ny\nz\nq\nr\ns"
+ .top.t yview 3.0
+ update
+ .top.t delete 2.0 4.0
+ list [.top.t index @0,0] [.top.t get @0,0]
+} -cleanup {
+ destroy .top
+} -result {2.0 y}
+test text-19.13 {DeleteChars procedure, updates affecting topIndex} -setup {
+ toplevel .top
+ text .top.t -width 1 -height 10 -wrap char
+ pack .top.t -side left
+ wm geometry .top +0+0
+ update
+} -body {
+ .top.t insert end "abcde\n12345\nqrstuv"
+ .top.t yview 2.1
+ .top.t delete 1.4 2.3
+ .top.t index @0,0
+} -cleanup {
+ destroy .top
+} -result {1.2}
+test text-19.14 {DeleteChars procedure, updates affecting topIndex} -setup {
+ toplevel .top
+ text .top.t -width 1 -height 10 -wrap char
+ pack .top.t -side left
+ wm geometry .top +0+0
+ update
+} -body {
+ .top.t insert end "abcde\n12345\nqrstuv"
+ .top.t yview 2.1
+ .top.t delete 2.3 2.4
+ .top.t index @0,0
+} -cleanup {
+ destroy .top
+} -result {2.0}
+test text-19.15 {DeleteChars procedure, updates affecting topIndex} -setup {
+ toplevel .top
+ text .top.t -width 1 -height 10 -wrap char
+ pack .top.t -side left
+ wm geometry .top +0+0
+ update
+} -body {
+ .top.t insert end "abcde\n12345\nqrstuv"
+ .top.t yview 1.3
+ .top.t delete 1.0 1.2
+ .top.t index @0,0
+} -cleanup {
+ destroy .top
+} -result {1.1}
+test text-19.16 {DeleteChars procedure, updates affecting topIndex} -setup {
+ toplevel .top
+ text .top.t -width 6 -height 10 -wrap word
+ frame .top.f -width 200 -height 20 -relief raised -bd 2
+ pack .top.f .top.t -side left
+ wm geometry .top +0+0
+ update
+} -body {
+ .top.t insert end "abc def\n01 2345 678 9101112\nLine 3\nLine 4\nLine 5\n6\n7\n8\n"
+ .top.t yview 2.4
+ .top.t delete 2.5
+ set x [.top.t index @0,0]
+ .top.t delete 2.5
+ list $x [.top.t index @0,0]
+} -cleanup {
+ destroy .top
+} -result {2.3 2.0}
+
+
+test text-20.1 {TextFetchSelection procedure} -setup {
+ text .t -width 20 -height 10
+ pack append . .t {top expand fill}
+ update
+} -body {
+ foreach i {a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ .t insert end $i.0$i.1$i.2$i.3$i.4\n
+ }
.t tag add sel 1.3 3.4
selection get
-} {a.1a.2a.3a.4
+} -cleanup {
+ destroy .t
+} -result {a.1a.2a.3a.4
b.0b.1b.2b.3b.4
c.0c}
-test text-18.2 {TextFetchSelection procedure} {
+test text-20.2 {TextFetchSelection procedure} -setup {
+ text .t -width 20 -height 10
+ pack append . .t {top expand fill}
+ update
+} -body {
+ foreach i {a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ .t insert end $i.0$i.1$i.2$i.3$i.4\n
+ }
.t tag add x 1.2
.t tag add x 1.4
.t tag add x 2.0
@@ -1322,15 +3590,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
@@ -1339,674 +3625,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
@@ -2014,240 +4669,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.
@@ -2261,697 +4951,947 @@ See the package: marks for more information.
}
set pat {package: ([a-zA-Z0-9][-a-zA-Z0-9._+#/]*)}
- list [.t2 search -nolinestop -regexp -nocase -all -forwards \
+ list [.t search -nolinestop -regexp -nocase -all -forwards \
-count c -- $pat 1.0 end] $c
-} {{3.8 6.8 8.0 11.8} {20 26 13 14}}
-test text-20.135 {TextSearchCmd, backwards search overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "foobarfoobaaaaaaaaaaarfoo"
- .t2 search -backwards -regexp {fooba+rfoo} end
-} {1.6}
-test text-20.135.1 {TextSearchCmd, backwards search overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "foobarfoobaaaaaaaaaaarfoo"
- .t2 search -backwards -overlap -all -regexp {fooba+rfoo} end
-} {1.6 1.0}
-test text-20.135.2 {TextSearchCmd, backwards search overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "foobarfoobaaaaaaaaaaarfoo"
- .t2 search -backwards -all -regexp {fooba+rfoo} end
-} {1.6}
-test text-20.135.3 {TextSearchCmd, forwards search overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "foobarfoobaaaaaaaaaaarfoo"
- .t2 search -all -overlap -regexp {fooba+rfoo} end
-} {1.0 1.6}
-test text-20.135.4 {TextSearchCmd, forwards search overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "foobarfoobaaaaaaaaaaarfoo"
- .t2 search -all -regexp {fooba+rfoo} end
-} {1.0}
-test text-20.136 {TextSearchCmd, forward exact search overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "abababab"
- .t2 search -exact -overlap -all {abab} 1.0
-} {1.0 1.2 1.4}
-test text-20.136.1 {TextSearchCmd, forward exact search overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "abababab"
- .t2 search -exact -all {abab} 1.0
-} {1.0 1.4}
-test text-20.137 {TextSearchCmd, backward exact search overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "ababababab"
- .t2 search -exact -overlap -backwards -all {abab} end
-} {1.6 1.4 1.2 1.0}
-test text-20.137.1 {TextSearchCmd, backward exact search overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "ababababab"
- .t2 search -exact -backwards -all {abab} end
-} {1.6 1.2}
-test text-20.137.2 {TextSearchCmd, backward exact search overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "abababababab"
- .t2 search -exact -backwards -all {abab} end
-} {1.8 1.4 1.0}
-test text-20.138 {TextSearchCmd, forward exact search overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n"
- .t2 search -exact -overlap -all "foo\nbar\nfoo" 1.0
-} {1.0 3.0 5.0}
-test text-20.138.1 {TextSearchCmd, forward exact search no-overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n"
- .t2 search -exact -all "foo\nbar\nfoo" 1.0
-} {1.0 5.0}
-test text-20.139 {TextSearchCmd, backward exact search overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n"
- .t2 search -exact -overlap -backward -all "foo\nbar\nfoo" end
-} {5.0 3.0 1.0}
-test text-20.140 {TextSearchCmd, backward exact search no-overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n"
- .t2 search -exact -backward -all "foo\nbar\nfoo" end
-} {5.0 1.0}
-test text-20.141 {TextSearchCmd, backward exact search overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n"
- .t2 search -regexp -backward -overlap -all "foo\nbar\nfoo" end
-} {5.0 3.0 1.0}
-test text-20.142 {TextSearchCmd, backward regexp search no-overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n"
- .t2 search -regexp -backward -all "foo\nbar\nfoo" end
-} {5.0 1.0}
-test text-20.142a {TextSearchCmd, backward regexp search no-overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 " aasda asdj werwer"
- .t2 search -regexp -backward -- {(\$)?[\w:_]+} 1.9
-} {1.7}
-test text-20.143 {TextSearchCmd, backward regexp search no-overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 " aasda asdj werwer"
- .t2 search -regexp -backward -- {(\$)?[\w:_]+} 1.9 1.5
-} {1.7}
-test text-20.144 {TextSearchCmd, backward regexp search no-overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 " aasda asdj werwer"
- .t2 search -regexp -backward -- {(\$)?[\w:_]+} 1.9 1.7
-} {1.7}
-test text-20.145 {TextSearchCmd, backward regexp search no-overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 " aasda asdj werwer"
- .t2 search -regexp -backward -- {(\$)?[\w:_]+} 1.9 1.8
-} {1.8}
-test text-20.146 {TextSearchCmd, backward regexp search no-overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 " aasda asdj werwer"
- .t2 search -regexp -backward -all -- {(\$)?[\w:_]+} 1.9 1.3
-} {1.7 1.3}
-test text-20.147 {TextSearchCmd, backward regexp search no-overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 " aasda asdj werwer"
- .t2 search -regexp -backward -all -- {(\$)?[\w:_]+} 1.9 1.13
-} {}
-test text-20.148 {TextSearchCmd, backward regexp search no-overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 " aasda asdj werwer"
- .t2 search -regexp -backward -all -- {(\$)?[\w:_]+} 2.0 1.3
-} {1.12 1.7 1.3}
-test text-20.149 {TextSearchCmd, backward regexp search no-overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 " aasda asdj werwer"
- .t2 search -regexp -backward -all -- {(\$)?[\w:_]+} 1.3
-} {1.1 1.12 1.7 1.3}
-test text-20.150 {TextSearchCmd, backward regexp search no-overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "abcde\nabcde\nabcde\n"
- .t2 search -regexp -backward -all -- {(\w+\n)+} end
-} {1.0}
-test text-20.151 {TextSearchCmd, backward regexp search no-overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "abcde\nabcde\nabcde\n"
- .t2 search -regexp -backward -all -- {(\w+\n)+} end 1.5
-} {2.0}
-test text-20.152 {TextSearchCmd, backward regexp search no-overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "abcde\nabcde\nabcde\na"
- .t2 search -regexp -backward -all -- {(\w+\n\w)+} end 1.5
-} {2.0}
-test text-20.153 {TextSearchCmd, backward regexp search no-overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "abcde\nabcde\nabcde\na"
- list [.t2 search -regexp -all -count foo -- {(\w+\n)+} 1.0] $foo
-} {1.0 20}
-test text-20.154 {TextSearchCmd, backward regexp search no-overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "abcde\nabcde\nabcde\na"
+} -cleanup {
+ destroy .t
+} -result {{3.8 6.8 8.0 11.8} {20 26 13 14}}
+test text-22.157 {TextSearchCmd, backwards search overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "foobarfoobaaaaaaaaaaarfoo"
+ .t search -backwards -regexp {fooba+rfoo} end
+} -cleanup {
+ destroy .t
+} -result {1.6}
+test text-22.158 {TextSearchCmd, backwards search overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "foobarfoobaaaaaaaaaaarfoo"
+ .t search -backwards -overlap -all -regexp {fooba+rfoo} end
+} -cleanup {
+ destroy .t
+} -result {1.6 1.0}
+test text-22.159 {TextSearchCmd, backwards search overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "foobarfoobaaaaaaaaaaarfoo"
+ .t search -backwards -all -regexp {fooba+rfoo} end
+} -cleanup {
+ destroy .t
+} -result {1.6}
+test text-22.160 {TextSearchCmd, forwards search overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "foobarfoobaaaaaaaaaaarfoo"
+ .t search -all -overlap -regexp {fooba+rfoo} end
+} -cleanup {
+ destroy .t
+} -result {1.0 1.6}
+test text-22.161 {TextSearchCmd, forwards search overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "foobarfoobaaaaaaaaaaarfoo"
+ .t search -all -regexp {fooba+rfoo} end
+} -cleanup {
+ destroy .t
+} -result {1.0}
+test text-22.162 {TextSearchCmd, forward exact search overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "abababab"
+ .t search -exact -overlap -all {abab} 1.0
+} -cleanup {
+ destroy .t
+} -result {1.0 1.2 1.4}
+test text-22.163 {TextSearchCmd, forward exact search overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "abababab"
+ .t search -exact -all {abab} 1.0
+} -cleanup {
+ destroy .t
+} -result {1.0 1.4}
+test text-22.164 {TextSearchCmd, backward exact search overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "ababababab"
+ .t search -exact -overlap -backwards -all {abab} end
+} -cleanup {
+ destroy .t
+} -result {1.6 1.4 1.2 1.0}
+test text-22.165 {TextSearchCmd, backward exact search overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "ababababab"
+ .t search -exact -backwards -all {abab} end
+} -cleanup {
+ destroy .t
+} -result {1.6 1.2}
+test text-22.166 {TextSearchCmd, backward exact search overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "abababababab"
+ .t search -exact -backwards -all {abab} end
+} -cleanup {
+ destroy .t
+} -result {1.8 1.4 1.0}
+test text-22.167 {TextSearchCmd, forward exact search overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n"
+ .t search -exact -overlap -all "foo\nbar\nfoo" 1.0
+} -cleanup {
+ destroy .t
+} -result {1.0 3.0 5.0}
+test text-22.168 {TextSearchCmd, forward exact search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n"
+ .t search -exact -all "foo\nbar\nfoo" 1.0
+} -cleanup {
+ destroy .t
+} -result {1.0 5.0}
+test text-22.169 {TextSearchCmd, backward exact search overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n"
+ .t search -exact -overlap -backward -all "foo\nbar\nfoo" end
+} -cleanup {
+ destroy .t
+} -result {5.0 3.0 1.0}
+test text-22.170 {TextSearchCmd, backward exact search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n"
+ .t search -exact -backward -all "foo\nbar\nfoo" end
+} -cleanup {
+ destroy .t
+} -result {5.0 1.0}
+test text-22.171 {TextSearchCmd, backward exact search overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n"
+ .t search -regexp -backward -overlap -all "foo\nbar\nfoo" end
+} -cleanup {
+ destroy .t
+} -result {5.0 3.0 1.0}
+test text-22.172 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n"
+ .t search -regexp -backward -all "foo\nbar\nfoo" end
+} -cleanup {
+ destroy .t
+} -result {5.0 1.0}
+test text-22.173 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 " aasda asdj werwer"
+ .t search -regexp -backward -- {(\$)?[\w:_]+} 1.9
+} -cleanup {
+ destroy .t
+} -result {1.7}
+test text-22.174 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 " aasda asdj werwer"
+ .t search -regexp -backward -- {(\$)?[\w:_]+} 1.9 1.5
+} -cleanup {
+ destroy .t
+} -result {1.7}
+test text-22.175 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 " aasda asdj werwer"
+ .t search -regexp -backward -- {(\$)?[\w:_]+} 1.9 1.7
+} -cleanup {
+ destroy .t
+} -result {1.7}
+test text-22.176 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 " aasda asdj werwer"
+ .t search -regexp -backward -- {(\$)?[\w:_]+} 1.9 1.8
+} -cleanup {
+ destroy .t
+} -result {1.8}
+test text-22.177 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 " aasda asdj werwer"
+ .t search -regexp -backward -all -- {(\$)?[\w:_]+} 1.9 1.3
+} -cleanup {
+ destroy .t
+} -result {1.7 1.3}
+test text-22.178 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 " aasda asdj werwer"
+ .t search -regexp -backward -all -- {(\$)?[\w:_]+} 1.9 1.13
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.179 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 " aasda asdj werwer"
+ .t search -regexp -backward -all -- {(\$)?[\w:_]+} 2.0 1.3
+} -cleanup {
+ destroy .t
+} -result {1.12 1.7 1.3}
+test text-22.180 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 " aasda asdj werwer"
+ .t search -regexp -backward -all -- {(\$)?[\w:_]+} 1.3
+} -cleanup {
+ destroy .t
+} -result {1.1 1.12 1.7 1.3}
+test text-22.181 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\n"
+ .t search -regexp -backward -all -- {(\w+\n)+} end
+} -cleanup {
+ destroy .t
+} -result {1.0}
+test text-22.182 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\n"
+ .t search -regexp -backward -all -- {(\w+\n)+} end 1.5
+} -cleanup {
+ destroy .t
+} -result {2.0}
+test text-22.183 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\na"
+ .t search -regexp -backward -all -- {(\w+\n\w)+} end 1.5
+} -cleanup {
+ destroy .t
+} -result {2.0}
+test text-22.184 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\na"
+ list [.t search -regexp -all -count foo -- {(\w+\n)+} 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {1.0 20}
+test text-22.185 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\na"
set res {}
lappend res \
- [list [.t2 search -regexp -all -count foo -- {(\w+\n)+} 1.0] $foo] \
- [list [.t2 search -regexp -all -count foo -- {(\w+)+} 1.0] $foo]
-} {{1.0 20} {{1.0 2.0 3.0 4.0} {5 5 5 1}}}
-test text-20.155 {TextSearchCmd, regexp search greedy} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "abcde\nabcde\nabcde\na"
- list [.t2 search -regexp -all -nolinestop -count foo -- {.*} 1.0] $foo
-} {1.0 20}
-test text-20.156 {TextSearchCmd, regexp search greedy} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "abcde\nabcde\nabcde\na"
- list [.t2 search -regexp -all -count foo -- {.*} 1.0] $foo
-} {{1.0 2.0 3.0 4.0} {5 5 5 1}}
-test text-20.157 {TextSearchCmd, regexp search greedy multi-line} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "abcde\nabcde\nabcde\na"
- list [.t2 search -regexp -count foo -- {(\w+\n\w)+} 1.0] $foo
-} {1.0 19}
-test text-20.158 {TextSearchCmd, regexp search greedy multi-line} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "abcde\nabcde\nabcde\na"
- list [.t2 search -regexp -backwards -count foo -- {(\w+\n\w)+} end] $foo
-} {1.0 19}
-test text-20.159 {TextSearchCmd, regexp search greedy multi-line} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "abcde\nabcde\nabcde\na"
- list [.t2 search -regexp -all -backwards -count foo -- {(\w+\n\w)+} end] $foo
-} {1.0 19}
-test text-20.160 {TextSearchCmd, backward regexp search no-overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "abcde\nabcde\nabcde\na"
- .t2 search -regexp -backward -all -- {(\w+\n\w)+} end 1.5
-} {2.0}
-test text-20.161 {TextSearchCmd, backward regexp search no-overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "abcde\nabcde\nabcde\na"
- .t2 search -regexp -backward -all -- {(\w+\n\w)+} end 1.3
-} {1.3}
-test text-20.162 {TextSearchCmd, backward regexp search no-overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "abcde\nabcde\nabcde\na"
- list [.t2 search -regexp -forward -count foo -- {(\w+\n\w)+} 1.3] $foo
-} {1.3 16}
-test text-20.163 {TextSearchCmd, backward regexp search no-overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "abcde\nabcde\nabcde\na"
- list [.t2 search -regexp -forward -all -count foo -- {(\w+\n\w)+} 1.3] $foo
- # This result is somewhat debatable -- the two results do overlap,
- # but only because the search has totally wrapped around back to
- # the start.
-} {{1.3 1.0} {16 19}}
-test text-20.164 {TextSearchCmd, backward regexp search no-overlaps} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "abcde\nabcde\nabcde\na"
- list [.t2 search -regexp -forward -all -count foo -- {(\w+\n\w)+} 1.0 1.3] $foo
-} {1.0 19}
-test text-20.165 {TextSearchCmd, regexp search multi-line} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "aaaa\nbbbb\naaaa\nbbbb\n"
- list [.t2 search -regexp -forward -all -count foo -- {(a+\n(b+\n))+} 1.0] $foo
-} {1.0 20}
-test text-20.166 {TextSearchCmd, regexp search complex cases} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "aaaa\nbbbb\naaaa\nbbbb\n"
- list [.t2 search -regexp -forward -all -count foo \
+ [list [.t search -regexp -all -count foo -- {(\w+\n)+} 1.0] $foo] \
+ [list [.t search -regexp -all -count foo -- {(\w+)+} 1.0] $foo]
+} -cleanup {
+ destroy .t
+} -result {{1.0 20} {{1.0 2.0 3.0 4.0} {5 5 5 1}}}
+test text-22.186 {TextSearchCmd, regexp search greedy} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\na"
+ list [.t search -regexp -all -nolinestop -count foo -- {.*} 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {1.0 20}
+test text-22.187 {TextSearchCmd, regexp search greedy} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\na"
+ list [.t search -regexp -all -count foo -- {.*} 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {{1.0 2.0 3.0 4.0} {5 5 5 1}}
+test text-22.188 {TextSearchCmd, regexp search greedy multi-line} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\na"
+ list [.t search -regexp -count foo -- {(\w+\n\w)+} 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {1.0 19}
+test text-22.189 {TextSearchCmd, regexp search greedy multi-line} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\na"
+ list [.t search -regexp -backwards -count foo -- {(\w+\n\w)+} end] $foo
+} -cleanup {
+ destroy .t
+} -result {1.0 19}
+test text-22.190 {TextSearchCmd, regexp search greedy multi-line} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\na"
+ list [.t search -regexp -all -backwards -count foo -- {(\w+\n\w)+} end] $foo
+} -cleanup {
+ destroy .t
+} -result {1.0 19}
+test text-22.191 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\na"
+ .t search -regexp -backward -all -- {(\w+\n\w)+} end 1.5
+} -cleanup {
+ destroy .t
+} -result {2.0}
+test text-22.192 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\na"
+ .t search -regexp -backward -all -- {(\w+\n\w)+} end 1.3
+} -cleanup {
+ destroy .t
+} -result {1.3}
+test text-22.193 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\na"
+ list [.t search -regexp -forward -count foo -- {(\w+\n\w)+} 1.3] $foo
+} -cleanup {
+ destroy .t
+} -result {1.3 16}
+test text-22.194 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\na"
+ list [.t search -regexp -forward -all -count foo -- {(\w+\n\w)+} 1.3] $foo
+# This result is somewhat debatable -- the two results do overlap,
+# but only because the search has totally wrapped around back to
+# the start.
+} -cleanup {
+ destroy .t
+} -result {{1.3 1.0} {16 19}}
+test text-22.195 {TextSearchCmd, backward regexp search no-overlaps} -body {
+ pack [text .t]
+ .t insert 1.0 "abcde\nabcde\nabcde\na"
+ list [.t search -regexp -forward -all -count foo -- {(\w+\n\w)+} 1.0 1.3] $foo
+} -cleanup {
+ destroy .t
+} -result {1.0 19}
+test text-22.196 {TextSearchCmd, regexp search multi-line} -body {
+ pack [text .t]
+ .t insert 1.0 "aaaa\nbbbb\naaaa\nbbbb\n"
+ list [.t search -regexp -forward -all -count foo -- {(a+\n(b+\n))+} 1.0] $foo
+} -cleanup {
+ destroy .t
+} -result {1.0 20}
+test text-22.197 {TextSearchCmd, regexp search complex cases} -body {
+ pack [text .t]
+ .t insert 1.0 "aaaa\nbbbb\naaaa\nbbbb\n"
+ list [.t search -regexp -forward -all -count foo \
-- {(a+\n(b+\n))+} 1.0] $foo
-} {1.0 20}
-test text-20.167 {TextSearchCmd, regexp search multi-line} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "aaaa\nbbbb\ncccc\nbbbb\naaaa\n"
+} -cleanup {
+ destroy .t
+} -result {1.0 20}
+test text-22.198 {TextSearchCmd, regexp search multi-line} -body {
+ pack [text .t]
+ .t insert 1.0 "aaaa\nbbbb\ncccc\nbbbb\naaaa\n"
set foo {}
- list [.t2 search -regexp -forward -all -count foo \
+ list [.t search -regexp -forward -all -count foo \
-- {(b+\nc+\nb+)\na+} 1.0] $foo
-} {2.0 19}
-test text-20.168 {TextSearchCmd, regexp search multi-line} {knownBug} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "aaaa\nbbbb\ncccc\nbbbb\naaaa\n"
+} -cleanup {
+ destroy .t
+} -result {2.0 19}
+test text-22.199 {TextSearchCmd, regexp search multi-line} -constraints {
+ knownBug
+} -body {
+ pack [text .t]
+ .t insert 1.0 "aaaa\nbbbb\ncccc\nbbbb\naaaa\n"
set foo {}
- list [.t2 search -regexp -forward -all -count foo \
+ list [.t search -regexp -forward -all -count foo \
-- {(a+|b+\nc+\nb+)\na+} 1.0] $foo
-} {2.0 19}
-test text-20.169 {TextSearchCmd, regexp search multi-line} {knownBug} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "aaaa\nbbbb\ncccc\nbbbb\naaaa\n"
+} -cleanup {
+ destroy .t
+} -result {2.0 19}
+test text-22.200 {TextSearchCmd, regexp search multi-line} -constraints {
+ knownBug
+} -body {
+ pack [text .t]
+ .t insert 1.0 "aaaa\nbbbb\ncccc\nbbbb\naaaa\n"
set foo {}
- list [.t2 search -regexp -forward -all -count foo \
+ list [.t search -regexp -forward -all -count foo \
-- {(a+|b+\nc+\nb+)+\na+} 1.0] $foo
-} {2.0 19}
-test text-20.170 {TextSearchCmd, regexp search multi-line} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "aaaa\nbbbb\ncccc\nbbbb\naaaa\n"
+} -cleanup {
+ destroy .t
+} -result {2.0 19}
+test text-22.201 {TextSearchCmd, regexp search multi-line} -body {
+ pack [text .t]
+ .t insert 1.0 "aaaa\nbbbb\ncccc\nbbbb\naaaa\n"
set foo {}
- list [.t2 search -regexp -forward -all -count foo \
+ list [.t search -regexp -forward -all -count foo \
-- {((a+|b+\nc+\nb+)+\n)+a+} 1.0] $foo
-} {1.0 24}
-test text-20.171 {TextSearchCmd, regexp search multi-line} {knownBug} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "aaaa\nbbbb\nbbbb\nbbbb\nbbbb\n"
- list [.t2 search -regexp -backward -all -count foo \
+} -cleanup {
+ destroy .t
+} -result {1.0 24}
+test text-22.202 {TextSearchCmd, regexp search multi-line} -constraints {
+ knownBug
+} -body {
+ pack [text .t]
+ .t insert 1.0 "aaaa\nbbbb\nbbbb\nbbbb\nbbbb\n"
+ list [.t search -regexp -backward -all -count foo \
-- {b+\n|a+\n(b+\n)+} end] $foo
-} {1.0 25}
-test text-20.172 {TextSearchCmd, regexp search multi-line} {knownBug} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "aaaa\nbbbb\nbbbb\nbbbb\nbbbb\n"
- .t2 search -regexp -backward -- {b+\n|a+\n(b+\n)+} end
- # Should match at 1.0 for a true greedy match
-} {1.0}
-test text-20.172.1 {TextSearchCmd, regexp search multi-line} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "line0\nline1\nline1\nline1\nline1\nline2\nline2\nline2\nline3\n"
- .t2 search -nolinestop -regexp -nocase -forwards -- {^(.*)\n(\1\n)+} 1.0 end
- # Matches at 6.0 currently
-} {2.0}
-test text-20.173 {TextSearchCmd, regexp search multi-line} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "\naaaxxx\nyyy\n"
+} -cleanup {
+ destroy .t
+} -result {1.0 25}
+test text-22.203 {TextSearchCmd, regexp search multi-line} -constraints {
+ knownBug
+} -body {
+ pack [text .t]
+ .t insert 1.0 "aaaa\nbbbb\nbbbb\nbbbb\nbbbb\n"
+ .t search -regexp -backward -- {b+\n|a+\n(b+\n)+} end
+# Should match at 1.0 for a true greedy match
+} -cleanup {
+ destroy .t
+} -result {1.0}
+test text-22.204 {TextSearchCmd, regexp search multi-line} -body {
+ pack [text .t]
+ .t insert 1.0 "line0\nline1\nline1\nline1\nline1\nline2\nline2\nline2\nline3\n"
+ .t search -nolinestop -regexp -nocase -forwards -- {^(.*)\n(\1\n)+} 1.0 end
+# Matches at 6.0 currently
+} -cleanup {
+ destroy .t
+} -result {2.0}
+test text-22.205 {TextSearchCmd, regexp search multi-line} -setup {
+ pack [text .t]
set res {}
- lappend res [.t2 search -count c -regexp -- {x*\ny*} 2.0] $c
- lappend res [.t2 search -count c -regexp -- {x*\ny*} 2.1] $c
- set res
-} {2.3 7 2.3 7}
-test text-20.174 {TextSearchCmd, regexp search multi-line} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "\naaa\n\n\n\n\nxxx\n"
+} -body {
+ .t insert 1.0 "\naaaxxx\nyyy\n"
+ lappend res [.t search -count c -regexp -- {x*\ny*} 2.0] $c
+ lappend res [.t search -count c -regexp -- {x*\ny*} 2.1] $c
+ return $res
+} -cleanup {
+ destroy .t
+} -result {2.3 7 2.3 7}
+test text-22.206 {TextSearchCmd, regexp search multi-line} -setup {
+ pack [text .t]
set res {}
- lappend res [.t2 search -count c -regexp -- {\n+} 2.0] $c
- lappend res [.t2 search -count c -regexp -- {\n+} 2.1] $c
- set res
-} {2.3 5 2.3 5}
-test text-20.175 {TextSearchCmd, regexp search multi-line} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "\naaa\n\n\t \n\t\t\t \n\nxxx\n"
+} -body {
+ .t insert 1.0 "\naaa\n\n\n\n\nxxx\n"
+ lappend res [.t search -count c -regexp -- {\n+} 2.0] $c
+ lappend res [.t search -count c -regexp -- {\n+} 2.1] $c
+ return $res
+} -cleanup {
+ destroy .t
+} -result {2.3 5 2.3 5}
+test text-22.207 {TextSearchCmd, regexp search multi-line} -setup {
+ pack [text .t]
set res {}
- lappend res [.t2 search -count c -regexp -- {(\n+(\t+ *)*)+} 2.0] $c
- set res
-} {2.3 13}
-test text-20.176 {TextSearchCmd, empty search range} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "a\na\na\n"
- .t2 search -- a 2.0 1.0
-} {}
-test text-20.177 {TextSearchCmd, empty search range} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "a\na\na\n"
- .t2 search -backwards -- a 1.0 2.0
-} {}
-test text-20.178 {TextSearchCmd, empty search range} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "a\na\na\n"
- .t2 search -- a 1.0 1.0
-} {}
-test text-20.179 {TextSearchCmd, empty search range} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "a\na\na\n"
- .t2 search -backwards -- a 2.0 2.0
-} {}
-test text-20.180 {TextSearchCmd, elide up to match} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "a\nb\nc"
- .t2 tag configure e -elide 1
+} -body {
+ .t insert 1.0 "\naaa\n\n\t \n\t\t\t \n\nxxx\n"
+ lappend res [.t search -count c -regexp -- {(\n+(\t+ *)*)+} 2.0] $c
+ return $res
+} -cleanup {
+ destroy .t
+} -result {2.3 13}
+test text-22.208 {TextSearchCmd, empty search range} -body {
+ pack [text .t]
+ .t insert 1.0 "a\na\na\n"
+ .t search -- a 2.0 1.0
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.209 {TextSearchCmd, empty search range} -body {
+ pack [text .t]
+ .t insert 1.0 "a\na\na\n"
+ .t search -backwards -- a 1.0 2.0
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.210 {TextSearchCmd, empty search range} -body {
+ pack [text .t]
+ .t insert 1.0 "a\na\na\n"
+ .t search -- a 1.0 1.0
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.211 {TextSearchCmd, empty search range} -body {
+ pack [text .t]
+ .t insert 1.0 "a\na\na\n"
+ .t search -backwards -- a 2.0 2.0
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.212 {TextSearchCmd, elide up to match} -setup {
+ pack [text .t]
set res {}
- lappend res [.t2 search -regexp a 1.0]
- lappend res [.t2 search -regexp b 1.0]
- lappend res [.t2 search -regexp c 1.0]
- .t2 tag add e 1.0 2.0
- lappend res [.t2 search -regexp a 1.0]
- lappend res [.t2 search -regexp b 1.0]
- lappend res [.t2 search -regexp c 1.0]
- lappend res [.t2 search -elide -regexp a 1.0]
- lappend res [.t2 search -elide -regexp b 1.0]
- lappend res [.t2 search -elide -regexp c 1.0]
-} {1.0 2.0 3.0 {} 2.0 3.0 1.0 2.0 3.0}
-test text-20.181 {TextSearchCmd, elide up to match, backwards} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "a\nb\nc"
- .t2 tag configure e -elide 1
+} -body {
+ .t insert 1.0 "a\nb\nc"
+ .t tag configure e -elide 1
+ lappend res [.t search -regexp a 1.0]
+ lappend res [.t search -regexp b 1.0]
+ lappend res [.t search -regexp c 1.0]
+ .t tag add e 1.0 2.0
+ lappend res [.t search -regexp a 1.0]
+ lappend res [.t search -regexp b 1.0]
+ lappend res [.t search -regexp c 1.0]
+ lappend res [.t search -elide -regexp a 1.0]
+ lappend res [.t search -elide -regexp b 1.0]
+ lappend res [.t search -elide -regexp c 1.0]
+} -cleanup {
+ destroy .t
+} -result {1.0 2.0 3.0 {} 2.0 3.0 1.0 2.0 3.0}
+test text-22.213 {TextSearchCmd, elide up to match, backwards} -setup {
+ pack [text .t]
set res {}
- lappend res [.t2 search -backward -regexp a 1.0]
- lappend res [.t2 search -backward -regexp b 1.0]
- lappend res [.t2 search -backward -regexp c 1.0]
- .t2 tag add e 1.0 2.0
- lappend res [.t2 search -backward -regexp a 1.0]
- lappend res [.t2 search -backward -regexp b 1.0]
- lappend res [.t2 search -backward -regexp c 1.0]
- lappend res [.t2 search -backward -elide -regexp a 1.0]
- lappend res [.t2 search -backward -elide -regexp b 1.0]
- lappend res [.t2 search -backward -elide -regexp c 1.0]
-} {1.0 2.0 3.0 {} 2.0 3.0 1.0 2.0 3.0}
-test text-20.182 {TextSearchCmd, elide up to match} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "a\nb\nc"
- .t2 tag configure e -elide 1
+} -body {
+ .t insert 1.0 "a\nb\nc"
+ .t tag configure e -elide 1
+ lappend res [.t search -backward -regexp a 1.0]
+ lappend res [.t search -backward -regexp b 1.0]
+ lappend res [.t search -backward -regexp c 1.0]
+ .t tag add e 1.0 2.0
+ lappend res [.t search -backward -regexp a 1.0]
+ lappend res [.t search -backward -regexp b 1.0]
+ lappend res [.t search -backward -regexp c 1.0]
+ lappend res [.t search -backward -elide -regexp a 1.0]
+ lappend res [.t search -backward -elide -regexp b 1.0]
+ lappend res [.t search -backward -elide -regexp c 1.0]
+} -cleanup {
+ destroy .t
+} -result {1.0 2.0 3.0 {} 2.0 3.0 1.0 2.0 3.0}
+test text-22.214 {TextSearchCmd, elide up to match} -setup {
+ pack [text .t]
set res {}
- lappend res [.t2 search a 1.0]
- lappend res [.t2 search b 1.0]
- lappend res [.t2 search c 1.0]
- .t2 tag add e 1.0 2.0
- lappend res [.t2 search a 1.0]
- lappend res [.t2 search b 1.0]
- lappend res [.t2 search c 1.0]
- lappend res [.t2 search -elide a 1.0]
- lappend res [.t2 search -elide b 1.0]
- lappend res [.t2 search -elide c 1.0]
-} {1.0 2.0 3.0 {} 2.0 3.0 1.0 2.0 3.0}
-test text-20.183 {TextSearchCmd, elide up to match, backwards} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "a\nb\nc"
- .t2 tag configure e -elide 1
+} -body {
+ .t insert 1.0 "a\nb\nc"
+ .t tag configure e -elide 1
+ lappend res [.t search a 1.0]
+ lappend res [.t search b 1.0]
+ lappend res [.t search c 1.0]
+ .t tag add e 1.0 2.0
+ lappend res [.t search a 1.0]
+ lappend res [.t search b 1.0]
+ lappend res [.t search c 1.0]
+ lappend res [.t search -elide a 1.0]
+ lappend res [.t search -elide b 1.0]
+ lappend res [.t search -elide c 1.0]
+} -cleanup {
+ destroy .t
+} -result {1.0 2.0 3.0 {} 2.0 3.0 1.0 2.0 3.0}
+test text-22.215 {TextSearchCmd, elide up to match, backwards} -setup {
+ pack [text .t]
set res {}
- lappend res [.t2 search -backward a 1.0]
- lappend res [.t2 search -backward b 1.0]
- lappend res [.t2 search -backward c 1.0]
- .t2 tag add e 1.0 2.0
- lappend res [.t2 search -backward a 1.0]
- lappend res [.t2 search -backward b 1.0]
- lappend res [.t2 search -backward c 1.0]
- lappend res [.t2 search -backward -elide a 1.0]
- lappend res [.t2 search -backward -elide b 1.0]
- lappend res [.t2 search -backward -elide c 1.0]
-} {1.0 2.0 3.0 {} 2.0 3.0 1.0 2.0 3.0}
-test text-20.184 {TextSearchCmd, elide up to match} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "aa\nbb\ncc"
- .t2 tag configure e -elide 1
+} -body {
+ .t insert 1.0 "a\nb\nc"
+ .t tag configure e -elide 1
+ lappend res [.t search -backward a 1.0]
+ lappend res [.t search -backward b 1.0]
+ lappend res [.t search -backward c 1.0]
+ .t tag add e 1.0 2.0
+ lappend res [.t search -backward a 1.0]
+ lappend res [.t search -backward b 1.0]
+ lappend res [.t search -backward c 1.0]
+ lappend res [.t search -backward -elide a 1.0]
+ lappend res [.t search -backward -elide b 1.0]
+ lappend res [.t search -backward -elide c 1.0]
+} -cleanup {
+ destroy .t
+} -result {1.0 2.0 3.0 {} 2.0 3.0 1.0 2.0 3.0}
+test text-22.216 {TextSearchCmd, elide up to match} -setup {
+ pack [text .t]
set res {}
- lappend res [.t2 search ab 1.0]
- lappend res [.t2 search bc 1.0]
- .t2 tag add e 1.1 2.1
- lappend res [.t2 search ab 1.0]
- lappend res [.t2 search b 1.0]
- .t2 tag remove e 1.0 end
- .t2 tag add e 2.1 3.1
- lappend res [.t2 search bc 1.0]
- lappend res [.t2 search c 1.0]
- .t2 tag remove e 1.0 end
- .t2 tag add e 2.1 3.0
- lappend res [.t2 search bc 1.0]
- lappend res [.t2 search c 1.0]
-} {{} {} 1.0 2.1 2.0 3.1 2.0 3.0}
-test text-20.185 {TextSearchCmd, elide up to match} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "aa\nbb\ncc"
- .t2 tag configure e -elide 1
+} -body {
+ .t insert 1.0 "aa\nbb\ncc"
+ .t tag configure e -elide 1
+ lappend res [.t search ab 1.0]
+ lappend res [.t search bc 1.0]
+ .t tag add e 1.1 2.1
+ lappend res [.t search ab 1.0]
+ lappend res [.t search b 1.0]
+ .t tag remove e 1.0 end
+ .t tag add e 2.1 3.1
+ lappend res [.t search bc 1.0]
+ lappend res [.t search c 1.0]
+ .t tag remove e 1.0 end
+ .t tag add e 2.1 3.0
+ lappend res [.t search bc 1.0]
+ lappend res [.t search c 1.0]
+} -cleanup {
+ destroy .t
+} -result {{} {} 1.0 2.1 2.0 3.1 2.0 3.0}
+test text-22.217 {TextSearchCmd, elide up to match} -setup {
+ pack [text .t]
set res {}
- lappend res [.t2 search -regexp ab 1.0]
- lappend res [.t2 search -regexp bc 1.0]
- .t2 tag add e 1.1 2.1
- lappend res [.t2 search -regexp ab 1.0]
- lappend res [.t2 search -regexp b 1.0]
- .t2 tag remove e 1.0 end
- .t2 tag add e 2.1 3.1
- lappend res [.t2 search -regexp bc 1.0]
- lappend res [.t2 search -regexp c 1.0]
- .t2 tag remove e 1.0 end
- .t2 tag add e 2.1 3.0
- lappend res [.t2 search -regexp bc 1.0]
- lappend res [.t2 search -regexp c 1.0]
-} {{} {} 1.0 2.1 2.0 3.1 2.0 3.0}
-test text-20.186 {TextSearchCmd, strict limits} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "Hello world!\nThis is a test\n"
- .t2 search -strictlimits -- "world" 1.3 1.8
-} {}
-test text-20.187 {TextSearchCmd, strict limits} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "Hello world!\nThis is a test\n"
- .t2 search -strictlimits -- "world" 1.3 1.10
-} {}
-test text-20.188 {TextSearchCmd, strict limits} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "Hello world!\nThis is a test\n"
- .t2 search -strictlimits -- "world" 1.3 1.11
-} {1.6}
-test text-20.189 {TextSearchCmd, strict limits backwards} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "Hello world!\nThis is a test\n"
- .t2 search -strictlimits -backward -- "world" 2.3 1.8
-} {}
-test text-20.190 {TextSearchCmd, strict limits backwards} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "Hello world!\nThis is a test\n"
- .t2 search -strictlimits -backward -- "world" 2.3 1.6
-} {1.6}
-test text-20.191 {TextSearchCmd, strict limits backwards} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "Hello world!\nThis is a test\n"
- .t2 search -strictlimits -backward -- "world" 2.3 1.7
-} {}
-test text-20.192 {TextSearchCmd, strict limits} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "Hello world!\nThis is a test\n"
- .t2 search -regexp -strictlimits -- "world" 1.3 1.8
-} {}
-test text-20.193 {TextSearchCmd, strict limits} {
- deleteWindows
- pack [text .t2]
- .t2 insert 1.0 "Hello world!\nThis is a test\n"
- .t2 search -regexp -strictlimits -backward -- "world" 2.3 1.8
-} {}
-
-deleteWindows
-text .t2 -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100
-pack .t2
-.t2 insert end "1\t2\t3\t4\t55.5"
-
-test text-21.1 {TkTextGetTabs procedure} {
- list [catch {.t2 configure -tabs "\{{}"} msg] $msg
-} {1 {unmatched open brace in list}}
-test text-21.2 {TkTextGetTabs procedure} {
- list [catch {.t2 configure -tabs xyz} msg] $msg
-} {1 {bad screen distance "xyz"}}
-test text-21.3 {TkTextGetTabs procedure} {
- .t2 configure -tabs {100 200}
+} -body {
+ .t insert 1.0 "aa\nbb\ncc"
+ .t tag configure e -elide 1
+ lappend res [.t search -regexp ab 1.0]
+ lappend res [.t search -regexp bc 1.0]
+ .t tag add e 1.1 2.1
+ lappend res [.t search -regexp ab 1.0]
+ lappend res [.t search -regexp b 1.0]
+ .t tag remove e 1.0 end
+ .t tag add e 2.1 3.1
+ lappend res [.t search -regexp bc 1.0]
+ lappend res [.t search -regexp c 1.0]
+ .t tag remove e 1.0 end
+ .t tag add e 2.1 3.0
+ lappend res [.t search -regexp bc 1.0]
+ lappend res [.t search -regexp c 1.0]
+} -cleanup {
+ destroy .t
+} -result {{} {} 1.0 2.1 2.0 3.1 2.0 3.0}
+test text-22.218 {TextSearchCmd, strict limits} -body {
+ pack [text .t]
+ .t insert 1.0 "Hello world!\nThis is a test\n"
+ .t search -strictlimits -- "world" 1.3 1.8
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.219 {TextSearchCmd, strict limits} -body {
+ pack [text .t]
+ .t insert 1.0 "Hello world!\nThis is a test\n"
+ .t search -strictlimits -- "world" 1.3 1.10
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.220 {TextSearchCmd, strict limits} -body {
+ pack [text .t]
+ .t insert 1.0 "Hello world!\nThis is a test\n"
+ .t search -strictlimits -- "world" 1.3 1.11
+} -cleanup {
+ destroy .t
+} -result {1.6}
+test text-22.221 {TextSearchCmd, strict limits backwards} -body {
+ pack [text .t]
+ .t insert 1.0 "Hello world!\nThis is a test\n"
+ .t search -strictlimits -backward -- "world" 2.3 1.8
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.222 {TextSearchCmd, strict limits backwards} -body {
+ pack [text .t]
+ .t insert 1.0 "Hello world!\nThis is a test\n"
+ .t search -strictlimits -backward -- "world" 2.3 1.6
+} -cleanup {
+ destroy .t
+} -result {1.6}
+test text-22.223 {TextSearchCmd, strict limits backwards} -body {
+ pack [text .t]
+ .t insert 1.0 "Hello world!\nThis is a test\n"
+ .t search -strictlimits -backward -- "world" 2.3 1.7
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.224 {TextSearchCmd, strict limits} -body {
+ pack [text .t]
+ .t insert 1.0 "Hello world!\nThis is a test\n"
+ .t search -regexp -strictlimits -- "world" 1.3 1.8
+} -cleanup {
+ destroy .t
+} -result {}
+test text-22.225 {TextSearchCmd, strict limits} -body {
+ pack [text .t]
+ .t insert 1.0 "Hello world!\nThis is a test\n"
+ .t search -regexp -strictlimits -backward -- "world" 2.3 1.8
+} -cleanup {
+ destroy .t
+} -result {}
+
+
+test text-23.1 {TkTextGetTabs procedure} -setup {
+ text .t -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100
+ pack .t
+} -body {
+ .t insert end "1\t2\t3\t4\t55.5"
+ .t configure -tabs "\{{}"
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {unmatched open brace in list}
+test text-23.2 {TkTextGetTabs procedure} -setup {
+ text .t -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100
+ pack .t
+} -body {
+ .t insert end "1\t2\t3\t4\t55.5"
+ .t configure -tabs xyz
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad screen distance "xyz"}
+test text-23.3 {TkTextGetTabs procedure} -setup {
+ text .t -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100
+ pack .t
+} -body {
+ .t insert end "1\t2\t3\t4\t55.5"
+ .t configure -tabs {100 200}
update idletasks
- list [lindex [.t2 bbox 1.2] 0] [lindex [.t2 bbox 1.4] 0]
-} {100 200}
-test text-21.4 {TkTextGetTabs procedure} {
- .t2 configure -tabs {100 right 200 left 300 center 400 numeric}
+ list [lindex [.t bbox 1.2] 0] [lindex [.t bbox 1.4] 0]
+} -cleanup {
+ destroy .t
+} -result {100 200}
+test text-23.4 {TkTextGetTabs procedure} -setup {
+ text .t -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100
+ pack .t
+} -body {
+ .t insert end "1\t2\t3\t4\t55.5"
+ .t configure -tabs {100 right 200 left 300 center 400 numeric}
update idletasks
- list [expr [lindex [.t2 bbox 1.2] 0] + [lindex [.t2 bbox 1.2] 2]] \
- [lindex [.t2 bbox 1.4] 0] \
- [expr [lindex [.t2 bbox 1.6] 0] + [lindex [.t2 bbox 1.6] 2]/2] \
- [lindex [.t2 bbox 1.10] 0]
-} {100 200 300 400}
-test text-21.5 {TkTextGetTabs procedure} {
- .t2 configure -tabs {105 r 205 l 305 c 405 n}
+ list [expr [lindex [.t bbox 1.2] 0] + [lindex [.t bbox 1.2] 2]] \
+ [lindex [.t bbox 1.4] 0] \
+ [expr [lindex [.t bbox 1.6] 0] + [lindex [.t bbox 1.6] 2]/2] \
+ [lindex [.t bbox 1.10] 0]
+} -cleanup {
+ destroy .t
+} -result {100 200 300 400}
+test text-23.5 {TkTextGetTabs procedure} -setup {
+ text .t -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100
+ pack .t
+} -body {
+ .t insert end "1\t2\t3\t4\t55.5"
+ .t configure -tabs {105 r 205 l 305 c 405 n}
update idletasks
- list [expr [lindex [.t2 bbox 1.2] 0] + [lindex [.t2 bbox 1.2] 2]] \
- [lindex [.t2 bbox 1.4] 0] \
- [expr [lindex [.t2 bbox 1.6] 0] + [lindex [.t2 bbox 1.6] 2]/2] \
- [lindex [.t2 bbox 1.10] 0]
-} {105 205 305 405}
-test text-21.6 {TkTextGetTabs procedure} {
- list [catch {.t2 configure -tabs {100 left 200 lork}} msg] $msg
-} {1 {bad tab alignment "lork": must be left, right, center, or numeric}}
-test text-21.7 {TkTextGetTabs procedure} {
- list [catch {.t2 configure -tabs {100 !44 200 lork}} msg] $msg
-} {1 {bad screen distance "!44"}}
-
-deleteWindows
-text .t
-pack .t
-.t insert 1.0 "One Line"
-.t mark set insert 1.0
-
-test text-22.1 {TextDumpCmd procedure, bad args} {
- list [catch {.t dump} msg] $msg
-} {1 {Usage: .t dump ?-all -image -text -mark -tag -window? ?-command script? index ?index2?}}
-test text-22.2 {TextDumpCmd procedure, bad args} {
- list [catch {.t dump -all} msg] $msg
-} {1 {Usage: .t dump ?-all -image -text -mark -tag -window? ?-command script? index ?index2?}}
-test text-22.3 {TextDumpCmd procedure, bad args} {
- list [catch {.t dump -command} msg] $msg
-} {1 {Usage: .t dump ?-all -image -text -mark -tag -window? ?-command script? index ?index2?}}
-test text-22.4 {TextDumpCmd procedure, bad args} {
- list [catch {.t dump -bogus} msg] $msg
-} {1 {bad option "-bogus": must be -all, -command, -image, -mark, -tag, -text, or -window}}
-test text-22.5 {TextDumpCmd procedure, bad args} {
- list [catch {.t dump bogus} msg] $msg
-} {1 {bad text index "bogus"}}
-test text-22.6 {TextDumpCmd procedure, one index} {
+ list [expr [lindex [.t bbox 1.2] 0] + [lindex [.t bbox 1.2] 2]] \
+ [lindex [.t bbox 1.4] 0] \
+ [expr [lindex [.t bbox 1.6] 0] + [lindex [.t bbox 1.6] 2]/2] \
+ [lindex [.t bbox 1.10] 0]
+} -cleanup {
+ destroy .t
+} -result {105 205 305 405}
+test text-23.6 {TkTextGetTabs procedure} -setup {
+ text .t -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100
+ pack .t
+} -body {
+ .t insert end "1\t2\t3\t4\t55.5"
+ .t configure -tabs {100 left 200 lork}
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad tab alignment "lork": must be left, right, center, or numeric}
+test text-23.7 {TkTextGetTabs procedure} -setup {
+ text .t -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100
+ pack .t
+} -body {
+ .t insert end "1\t2\t3\t4\t55.5"
+ .t configure -tabs {100 !44 200 lork}
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad screen distance "!44"}
+
+
+test text-24.1 {TextDumpCmd procedure, bad args} -body {
+ pack [text .t]
+ .t insert 1.0 "One Line"
+ .t mark set insert 1.0
+ .t dump
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {Usage: .t dump ?-all -image -text -mark -tag -window? ?-command script? index ?index2?}
+test text-24.2 {TextDumpCmd procedure, bad args} -body {
+ pack [text .t]
+ .t insert 1.0 "One Line"
+ .t mark set insert 1.0
+ .t dump -all
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {Usage: .t dump ?-all -image -text -mark -tag -window? ?-command script? index ?index2?}
+test text-24.3 {TextDumpCmd procedure, bad args} -body {
+ pack [text .t]
+ .t insert 1.0 "One Line"
+ .t mark set insert 1.0
+ .t dump -command
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {Usage: .t dump ?-all -image -text -mark -tag -window? ?-command script? index ?index2?}
+test text-24.4 {TextDumpCmd procedure, bad args} -body {
+ pack [text .t]
+ .t insert 1.0 "One Line"
+ .t mark set insert 1.0
+ .t dump -bogus
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad option "-bogus": must be -all, -command, -image, -mark, -tag, -text, or -window}
+test text-24.5 {TextDumpCmd procedure, bad args} -body {
+ pack [text .t]
+ .t insert 1.0 "One Line"
+ .t mark set insert 1.0
+ .t dump bogus
+} -cleanup {
+ destroy .t
+} -returnCodes {error} -result {bad text index "bogus"}
+test text-24.6 {TextDumpCmd procedure, one index} -body {
+ pack [text .t]
+ .t insert 1.0 "One Line"
.t dump -text 1.2
-} {text e 1.2}
-test text-22.7 {TextDumpCmd procedure, two indices} {
+} -cleanup {
+ destroy .t
+} -result {text e 1.2}
+test text-24.7 {TextDumpCmd procedure, two indices} -body {
+ pack [text .t]
+ .t insert 1.0 "One Line"
.t dump -text 1.0 1.end
-} {text {One Line} 1.0}
-test text-22.8 {TextDumpCmd procedure, "end" index} {
+} -cleanup {
+ destroy .t
+} -result {text {One Line} 1.0}
+test text-24.8 {TextDumpCmd procedure, "end" index} -body {
+ pack [text .t]
+ .t insert 1.0 "One Line"
.t dump -text 1.end end
-} {text {
+} -cleanup {
+ destroy .t
+} -result {text {
} 1.8}
-test text-22.9 {TextDumpCmd procedure, same indices} {
+test text-24.9 {TextDumpCmd procedure, same indices} -body {
+ pack [text .t]
+ .t insert 1.0 "One Line"
.t dump 1.5 1.5
-} {}
-test text-22.10 {TextDumpCmd procedure, negative range} {
+} -cleanup {
+ destroy .t
+} -result {}
+test text-24.10 {TextDumpCmd procedure, negative range} -body {
+ pack [text .t]
+ .t insert 1.0 "One Line"
+ .t mark set insert 1.0
.t dump 1.5 1.0
-} {}
-.t delete 1.0 end
-.t insert end "Line One\nLine Two\nLine Three\nLine Four"
-.t mark set insert 1.0
-.t mark set current 1.0
-test text-22.11 {TextDumpCmd procedure, stop at begin-line} {
+} -cleanup {
+ destroy .t
+} -result {}
+test text-24.11 {TextDumpCmd procedure, stop at begin-line} -body {
+ pack [text .t]
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
.t dump -text 1.0 2.0
-} {text {Line One
+} -cleanup {
+ destroy .t
+} -result {text {Line One
} 1.0}
-test text-22.12 {TextDumpCmd procedure, span multiple lines} {
+test text-24.12 {TextDumpCmd procedure, span multiple lines} -body {
+ pack [text .t]
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
.t dump -text 1.5 3.end
-} {text {One
+} -cleanup {
+ destroy .t
+} -result {text {One
} 1.5 text {Line Two
} 2.0 text {Line Three} 3.0}
-.t tag add x 2.0 2.end
-.t tag add y 1.0 end
-.t mark set m 2.4
-.t mark set n 4.0
-.t mark set END end
-test text-22.13 {TextDumpCmd procedure, tags only} {
+test text-24.13 {TextDumpCmd procedure, tags only} -body {
+ pack [text .t]
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
+ .t tag add x 2.0 2.end
+ .t tag add y 1.0 end
.t dump -tag 2.1 2.8
-} {}
-test text-22.14 {TextDumpCmd procedure, tags only} {
+} -cleanup {
+ destroy .t
+} -result {}
+test text-24.14 {TextDumpCmd procedure, tags only} -body {
+ pack [text .t]
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
+ .t tag add x 2.0 2.end
+ .t tag add y 1.0 end
.t dump -tag 2.0 2.8
-} {tagon x 2.0}
-test text-22.15 {TextDumpCmd procedure, tags only} {
+} -cleanup {
+ destroy .t
+} -result {tagon x 2.0}
+test text-24.15 {TextDumpCmd procedure, tags only} -body {
+ pack [text .t]
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
+ .t tag add x 2.0 2.end
+ .t tag add y 1.0 end
.t dump -tag 1.0 4.end
-} {tagon y 1.0 tagon x 2.0 tagoff x 2.8}
-test text-22.16 {TextDumpCmd procedure, tags only} {
+} -cleanup {
+ destroy .t
+} -result {tagon y 1.0 tagon x 2.0 tagoff x 2.8}
+test text-24.16 {TextDumpCmd procedure, tags only} -body {
+ pack [text .t]
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
+ .t tag add x 2.0 2.end
+ .t tag add y 1.0 end
.t dump -tag 1.0 end
-} {tagon y 1.0 tagon x 2.0 tagoff x 2.8 tagoff y 5.0}
-.t mark set insert 1.0
-.t mark set current 1.0
-test text-22.17 {TextDumpCmd procedure, marks only} {
+} -cleanup {
+ destroy .t
+} -result {tagon y 1.0 tagon x 2.0 tagoff x 2.8 tagoff y 5.0}
+test text-24.17 {TextDumpCmd procedure, marks only} -body {
+ pack [text .t]
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
+ .t mark set insert 1.0
+ .t mark set current 1.0
+ .t mark set m 2.4
+ .t mark set n 4.0
+ .t mark set END end
.t dump -mark 1.1 1.8
-} {}
-test text-22.18 {TextDumpCmd procedure, marks only} {
+} -cleanup {
+ destroy .t
+} -result {}
+test text-24.18 {TextDumpCmd procedure, marks only} -body {
+ pack [text .t]
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
+ .t mark set insert 1.0
+ .t mark set current 1.0
+ .t mark set m 2.4
+ .t mark set n 4.0
+ .t mark set END end
.t dump -mark 2.0 2.8
-} {mark m 2.4}
-test text-22.19 {TextDumpCmd procedure, marks only} {
+} -cleanup {
+ destroy .t
+} -result {mark m 2.4}
+test text-24.19 {TextDumpCmd procedure, marks only} -body {
+ pack [text .t]
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
+ .t mark set insert 1.0
+ .t mark set current 1.0
+ .t mark set m 2.4
+ .t mark set n 4.0
+ .t mark set END end
.t dump -mark 1.1 4.end
-} {mark m 2.4 mark n 4.0}
-test text-22.20 {TextDumpCmd procedure, marks only} {
+} -cleanup {
+ destroy .t
+} -result {mark m 2.4 mark n 4.0}
+test text-24.20 {TextDumpCmd procedure, marks only} -body {
+ pack [text .t]
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
+ .t mark set insert 1.0
+ .t mark set current 1.0
+ .t mark set m 2.4
+ .t mark set n 4.0
+ .t mark set END end
.t dump -mark 1.0 end
-} {mark current 1.0 mark insert 1.0 mark m 2.4 mark n 4.0 mark END 5.0}
-button .hello -text Hello
-.t window create 3.end -window .hello
-for {set i 0} {$i < 100} {incr i} {
- .t insert end "-\n"
-}
-.t window create 100.0 -create { }
-test text-22.21 {TextDumpCmd procedure, windows only} {
+} -cleanup {
+ destroy .t
+} -result {mark current 1.0 mark insert 1.0 mark m 2.4 mark n 4.0 mark END 5.0}
+test text-24.21 {TextDumpCmd procedure, windows only} -setup {
+ pack [text .t]
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
+ for {set i 0} {$i < 100} {incr i} {.t insert end "-\n"}
+ button .hello -text Hello
+} -body {
+ .t window create 3.end -window .hello
+ .t window create 100.0 -create { }
.t dump -window 1.0 5.0
-} {window .hello 3.10}
-test text-22.22 {TextDumpCmd procedure, windows only} {
+} -cleanup {
+ destroy .t
+} -result {window .hello 3.10}
+test text-24.22 {TextDumpCmd procedure, windows only} -setup {
+ pack [text .t]
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
+ for {set i 0} {$i < 100} {incr i} {.t insert end "-\n"}
+ button .hello -text Hello
+} -body {
+ .t window create 3.end -window .hello
+ .t window create 100.0 -create { }
.t dump -window 5.0 end
-} {window {} 100.0}
-.t delete 1.0 end
-eval {.t mark unset} [.t mark names]
-.t insert end "Line One\nLine Two\nLine Three\nLine Four"
-.t mark set insert 1.0
-.t mark set current 1.0
-.t tag add x 2.0 2.end
-.t mark set m 2.4
-proc Append {varName key value index} {
- upvar #0 $varName x
- lappend x $key $index $value
-}
-test text-22.23 {TextDumpCmd procedure, command script} {
+} -cleanup {
+ destroy .t
+} -result {window {} 100.0}
+test text-24.23 {TextDumpCmd procedure, command script} -setup {
set x {}
+ pack [text .t]
+ proc Append {varName key value index} {
+ upvar #0 $varName x
+ lappend x $key $index $value
+ }
+} -body {
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
+ .t mark set insert 1.0
+ .t mark set current 1.0
+ .t tag add x 2.0 2.end
+ .t mark set m 2.4
.t dump -command {Append x} -all 1.0 end
- set x
-} {mark 1.0 current mark 1.0 insert text 1.0 {Line One
+ return $x
+} -cleanup {
+ destroy .t
+ rename Append {}
+} -result {mark 1.0 current mark 1.0 insert text 1.0 {Line One
} tagon 2.0 x text 2.0 Line mark 2.4 m text 2.4 { Two} tagoff 2.8 x text 2.8 {
} text 3.0 {Line Three
} text 4.0 {Line Four
}}
-test text-22.24 {TextDumpCmd procedure, command script} {
+test text-24.24 {TextDumpCmd procedure, command script} -setup {
set x {}
+ pack [text .t]
+ proc Append {varName key value index} {
+ upvar #0 $varName x
+ lappend x $key $index $value
+ }
+} -body {
+ .t insert end "Line One\nLine Two\nLine Three\nLine Four"
+ .t mark set insert 1.0
+ .t mark set current 1.0
+ .t mark set m 2.4
.t dump -mark -command {Append x} 1.0 end
- set x
-} {mark 1.0 current mark 1.0 insert mark 2.4 m}
-catch {unset x}
-test text-22.25 {TextDumpCmd procedure, unicode characters} {
- catch {destroy .t}
+ return $x
+} -cleanup {
+ destroy .t
+ rename Append {}
+} -result {mark 1.0 current mark 1.0 insert mark 2.4 m}
+test text-24.25 {TextDumpCmd procedure, unicode characters} -body {
text .t
- .t delete 1.0 end
.t insert 1.0 \xb1\xb1\xb1
.t dump -all 1.0 2.0
-} "text \xb1\xb1\xb1 1.0 mark insert 1.3 mark current 1.3 text {\n} 1.3"
-test text-22.26 {TextDumpCmd procedure, unicode characters} {
- catch {destroy .t}
+} -cleanup {
+ destroy .t
+} -result "text \xb1\xb1\xb1 1.0 mark insert 1.3 mark current 1.3 text {\n} 1.3"
+test text-24.26 {TextDumpCmd procedure, unicode characters} -body {
text .t
.t delete 1.0 end
.t insert 1.0 abc\xb1\xb1\xb1
.t dump -all 1.0 2.0
-} "text abc\xb1\xb1\xb1 1.0 mark insert 1.6 mark current 1.6 text {\n} 1.6"
-test text-22.27 {TextDumpCmd procedure, peer present} -setup {
+} -cleanup {
destroy .t
-} -body {
+} -result "text abc\xb1\xb1\xb1 1.0 mark insert 1.6 mark current 1.6 text {\n} 1.6"
+test text-24.27 {TextDumpCmd procedure, peer present} -body {
text .t
.t peer create .t.t
.t dump -all 1.0 end
@@ -2959,21 +5899,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"
@@ -2981,16 +5918,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"
@@ -2998,9 +5943,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"
@@ -3009,9 +5955,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"
@@ -3019,10 +5966,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"
@@ -3030,9 +5978,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"
@@ -3040,36 +5989,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
@@ -3077,50 +6031,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"
@@ -3130,17 +6088,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
@@ -3153,246 +6114,275 @@ test text-25.18 {patch 1469210 - inserting after undo} -setup {
destroy .t
} -result 1
-test text-26.1 {bug fix - 624372, ControlUtfProc long lines} {
- destroy .t
+test text-28.1 {bug fix - 624372, ControlUtfProc long lines} -body {
pack [text .t -wrap none]
.t insert end [string repeat "\1" 500]
-} {}
-
-test text-27.1 {tabs - must be positive and must be increasing} {
+} -cleanup {
destroy .t
+} -result {}
+
+
+test text-29.1 {tabs - must be positive and must be increasing} -body {
pack [text .t -wrap none]
- list [catch {.t configure -tabs {0}} msg] $msg
-} {1 {tab stop "0" is not at a positive distance}}
-test text-27.2 {tabs - must be positive and must be increasing} {
+ .t configure -tabs {0}
+} -cleanup {
destroy .t
+} -returnCodes {error} -result {tab stop "0" is not at a positive distance}
+test text-29.2 {tabs - must be positive and must be increasing} -body {
pack [text .t -wrap none]
- list [catch {.t configure -tabs {-5}} msg] $msg
-} {1 {tab stop "-5" is not at a positive distance}}
-test text-27.3 {tabs - must be positive and must be increasing} {knownBug} {
- # This bug will be fixed in Tk 9.0, when we can allow a minor
- # incompatibility with Tk 8.x
+ .t configure -tabs {-5}
+} -cleanup {
destroy .t
+} -returnCodes {error} -result {tab stop "-5" is not at a positive distance}
+test text-29.3 {tabs - must be positive and must be increasing} -constraints {
+ knownBug
+} -body {
+# This bug will be fixed in Tk 9.0, when we can allow a minor
+# incompatibility with Tk 8.x
pack [text .t -wrap none]
- list [catch {.t configure -tabs {10c 5c}} msg] $msg
-} {1 {tabs must be monotonically increasing, but "5c" is smaller than or equal to the previous tab}}
-test text-27.4 {tabs - must be positive and must be increasing} {
+ .t configure -tabs {10c 5c}
+} -cleanup {
destroy .t
+} -returnCodes {error} -result {tabs must be monotonically increasing, but "5c" is smaller than or equal to the previous tab}
+test text-29.4 {tabs - must be positive and must be increasing} -body {
pack [text .t -wrap none]
.t insert end "a\tb\tc\td\te"
catch {.t configure -tabs {10c 5c}}
update ; update ; update
- # This test must simply not go into an infinite loop to succeed
+# This test must simply not go into an infinite loop to succeed
+ set result 1
+} -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]
@@ -3402,17 +6392,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] \
@@ -3421,17 +6412,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] \
@@ -3440,16 +6432,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}]
@@ -3458,58 +6451,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]
@@ -3517,63 +6513,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}]
@@ -3582,12 +6603,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}]
@@ -3596,16 +6619,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]
@@ -3619,8 +6645,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
@@ -3713,45 +6741,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}
@@ -3766,7 +6801,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 {}
@@ -3780,7 +6814,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 {}
@@ -3794,7 +6827,11 @@ test text-36.3 "bug #1777362: event handling with hyphenated windows" -setup {
} -cleanup {
destroy $w
} -result {}
-
+
# cleanup
cleanupTests
return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/textBTree.test b/tests/textBTree.test
index 3a89e55..41b3d98 100644
--- a/tests/textBTree.test
+++ b/tests/textBTree.test
@@ -8,642 +8,848 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
-catch {destroy .t}
+proc setup {} {
+ .t delete 1.0 100000.0
+ .t tag delete x y
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ .t tag add x 1.1
+ .t tag add x 1.5 1.13
+ .t tag add x 2.2 2.6
+ .t tag add y 1.5
+}
+
+# setup procedure for tests 10.*, 11.*, 12.*
+proc msetup {} {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ .t mark set m1 1.2
+ .t mark set l1 1.2
+ .t mark gravity l1 left
+ .t mark set next 1.6
+ .t mark set x 1.6
+ .t mark set m2 2.0
+ .t mark set m3 2.100
+ .t tag add x 1.3 1.8
+}
+
+# setup procedure for tests 16.*, 17.*, 18.9
+proc setupBig {} {
+ .t delete 1.0 end
+ .t tag delete x y
+ .t tag configure x -foreground blue
+ .t tag configure y -underline true
+ # Create a Btree with 2002 lines (2000 + already existing + phantom at end)
+ # This generates a level 3 node with 9 children
+ # Most level 2 nodes cover 216 lines and have 6 children, except the last
+ # level 2 node covers 274 lines and has 7 children.
+ # Most level 1 nodes cover 36 lines and have 6 children, except the
+ # rightmost node has 58 lines and 9 children.
+ # Level 2: 2002 = 8*216 + 274
+ # Level 1: 2002 = 54*36 + 58
+ # Level 0: 2002 = 332*6 + 10
+ for {set i 0} {$i < 2000} {incr i} {
+ append x "Line $i abcd efgh ijkl\n"
+ }
+ .t insert insert $x
+ .t debug 1
+}
+
+# Widget used in tests 1.* - 13.*
+destroy .t
text .t
.t debug on
-test btree-1.1 {basic insertions} {
+test btree-1.1 {basic insertions} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t get 1.0 1000000.0
-} "Line 1\nLine 2\nLine 3\n"
-test btree-1.2 {basic insertions} {
+} -result "Line 1\nLine 2\nLine 3\n"
+test btree-1.2 {basic insertions} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t insert 1.3 XXX
.t get 1.0 1000000.0
-} "LinXXXe 1\nLine 2\nLine 3\n"
-test btree-1.3 {basic insertions} {
+} -result "LinXXXe 1\nLine 2\nLine 3\n"
+test btree-1.3 {basic insertions} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t insert 3.0 YYY
.t get 1.0 1000000.0
-} "Line 1\nLine 2\nYYYLine 3\n"
-test btree-1.4 {basic insertions} {
+} -result "Line 1\nLine 2\nYYYLine 3\n"
+test btree-1.4 {basic insertions} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t insert 2.1 X\nYY
.t get 1.0 1000000.0
-} "Line 1\nLX\nYYine 2\nLine 3\n"
-test btree-1.5 {basic insertions} {
+} -result "Line 1\nLX\nYYine 2\nLine 3\n"
+test btree-1.5 {basic insertions} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t insert 2.0 X\n\n\n
.t get 1.0 1000000.0
-} "Line 1\nX\n\n\nLine 2\nLine 3\n"
-test btree-1.6 {basic insertions} {
+} -result "Line 1\nX\n\n\nLine 2\nLine 3\n"
+test btree-1.6 {basic insertions} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t insert 2.6 X\n
.t get 1.0 1000000.0
-} "Line 1\nLine 2X\n\nLine 3\n"
-test btree-1.7 {insertion before start of text} {
+} -result "Line 1\nLine 2X\n\nLine 3\n"
+test btree-1.7 {insertion before start of text} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t insert 0.4 XXX
.t get 1.0 1000000.0
-} "XXXLine 1\nLine 2\nLine 3\n"
-test btree-1.8 {insertion past end of text} {
+} -result "XXXLine 1\nLine 2\nLine 3\n"
+test btree-1.8 {insertion past end of text} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t insert 100.0 ZZ
.t get 1.0 1000000.0
-} "Line 1\nLine 2\nLine 3ZZ\n"
-test btree-1.9 {insertion before start of line} {
+} -result "Line 1\nLine 2\nLine 3ZZ\n"
+test btree-1.9 {insertion before start of line} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t insert 2.-3 Q
.t get 1.0 1000000.0
-} "Line 1\nQLine 2\nLine 3\n"
-test btree-1.10 {insertion past end of line} {
+} -result "Line 1\nQLine 2\nLine 3\n"
+test btree-1.10 {insertion past end of line} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t insert 2.40 XYZZY
.t get 1.0 1000000.0
-} "Line 1\nLine 2XYZZY\nLine 3\n"
-test btree-1.11 {insertion past end of last line} {
+} -result "Line 1\nLine 2XYZZY\nLine 3\n"
+test btree-1.11 {insertion past end of last line} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t insert 3.40 ABC
.t get 1.0 1000000.0
-} "Line 1\nLine 2\nLine 3ABC\n"
+} -result "Line 1\nLine 2\nLine 3ABC\n"
+
-test btree-2.1 {basic deletions} {
+test btree-2.1 {basic deletions} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 1.0 1.3
.t get 1.0 1000000.0
-} "e 1\nLine 2\nLine 3\n"
-test btree-2.2 {basic deletions} {
+} -result "e 1\nLine 2\nLine 3\n"
+test btree-2.2 {basic deletions} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 2.2
.t get 1.0 1000000.0
-} "Line 1\nLie 2\nLine 3\n"
-test btree-2.3 {basic deletions} {
+} -result "Line 1\nLie 2\nLine 3\n"
+test btree-2.3 {basic deletions} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 2.0 2.3
.t get 1.0 1000000.0
-} "Line 1\ne 2\nLine 3\n"
-test btree-2.4 {deleting whole lines} {
+} -result "Line 1\ne 2\nLine 3\n"
+test btree-2.4 {deleting whole lines} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 1.2 3.0
.t get 1.0 1000000.0
-} "LiLine 3\n"
-test btree-2.5 {deleting whole lines} {
+} -result "LiLine 3\n"
+test btree-2.5 {deleting whole lines} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\n\n\nLine 5"
.t delete 1.0 5.2
.t get 1.0 1000000.0
-} "ne 5\n"
-test btree-2.6 {deleting before start of file} {
+} -result "ne 5\n"
+test btree-2.6 {deleting before start of file} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 0.3 1.2
.t get 1.0 1000000.0
-} "ne 1\nLine 2\nLine 3\n"
-test btree-2.7 {deleting after end of file} {
+} -result "ne 1\nLine 2\nLine 3\n"
+test btree-2.7 {deleting after end of file} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 10.3
.t get 1.0 1000000.0
-} "Line 1\nLine 2\nLine 3\n"
-test btree-2.8 {deleting before start of line} {
+} -result "Line 1\nLine 2\nLine 3\n"
+test btree-2.8 {deleting before start of line} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 3.-1 3.3
.t get 1.0 1000000.0
-} "Line 1\nLine 2\ne 3\n"
-test btree-2.9 {deleting before start of line} {
+} -result "Line 1\nLine 2\ne 3\n"
+test btree-2.9 {deleting before start of line} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 1.-1 1.0
.t get 1.0 1000000.0
-} "Line 1\nLine 2\nLine 3\n"
-test btree-2.10 {deleting after end of line} {
+} -result "Line 1\nLine 2\nLine 3\n"
+test btree-2.10 {deleting after end of line} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 1.8 2.1
.t get 1.0 1000000.0
-} "Line 1ine 2\nLine 3\n"
-test btree-2.11 {deleting after end of last line} {
+} -result "Line 1ine 2\nLine 3\n"
+test btree-2.11 {deleting after end of last line} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 3.8 4.1
.t get 1.0 1000000.0
-} "Line 1\nLine 2\nLine 3\n"
-test btree-2.12 {deleting before start of file} {
+} -result "Line 1\nLine 2\nLine 3\n"
+test btree-2.12 {deleting before start of file} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 1.8 0.0
.t get 1.0 1000000.0
-} "Line 1\nLine 2\nLine 3\n"
-test btree-2.13 {deleting past end of file} {
+} -result "Line 1\nLine 2\nLine 3\n"
+test btree-2.13 {deleting past end of file} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 1.8 4.0
.t get 1.0 1000000.0
-} "Line 1\n"
-test btree-2.14 {deleting with end before start of line} {
+} -result "Line 1\n"
+test btree-2.14 {deleting with end before start of line} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 1.3 2.-3
.t get 1.0 1000000.0
-} "LinLine 2\nLine 3\n"
-test btree-2.15 {deleting past end of line} {
+} -result "LinLine 2\nLine 3\n"
+test btree-2.15 {deleting past end of line} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 1.3 1.9
.t get 1.0 1000000.0
-} "Lin\nLine 2\nLine 3\n"
-test btree-2.16 {deleting past end of line} {
+} -result "Lin\nLine 2\nLine 3\n"
+test btree-2.16 {deleting past end of line} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 3.2 3.15
.t get 1.0 1000000.0
-} "Line 1\nLine 2\nLi\n"
-test btree-2.17 {deleting past end of line} {
+} -result "Line 1\nLine 2\nLi\n"
+test btree-2.17 {deleting past end of line} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 3.0 3.15
.t get 1.0 1000000.0
-} "Line 1\nLine 2\n\n"
-test btree-2.18 {deleting past end of line} {
+} -result "Line 1\nLine 2\n\n"
+test btree-2.18 {deleting past end of line} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 1.0 3.15
.t get 1.0 1000000.0
-} "\n"
-test btree-2.19 {deleting with negative range} {
+} -result "\n"
+test btree-2.19 {deleting with negative range} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 3.2 2.4
.t get 1.0 1000000.0
-} "Line 1\nLine 2\nLine 3\n"
-test btree-2.20 {deleting with negative range} {
+} -result "Line 1\nLine 2\nLine 3\n"
+test btree-2.20 {deleting with negative range} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 3.2 3.1
.t get 1.0 1000000.0
-} "Line 1\nLine 2\nLine 3\n"
-test btree-2.21 {deleting with negative range} {
+} -result "Line 1\nLine 2\nLine 3\n"
+test btree-2.21 {deleting with negative range} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 3.2 3.2
.t get 1.0 1000000.0
-} "Line 1\nLine 2\nLine 3\n"
+} -result "Line 1\nLine 2\nLine 3\n"
-proc setup {} {
- .t delete 1.0 100000.0
- .t tag delete x y
- .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
- .t tag add x 1.1
- .t tag add x 1.5 1.13
- .t tag add x 2.2 2.6
- .t tag add y 1.5
-}
-test btree-3.1 {inserting with tags} {
+test btree-3.1 {inserting with tags} -body {
setup
.t insert 1.0 XXX
list [.t tag ranges x] [.t tag ranges y]
-} {{1.4 1.5 1.8 1.16 2.2 2.6} {1.8 1.9}}
-test btree-3.2 {inserting with tags} {
+} -result {{1.4 1.5 1.8 1.16 2.2 2.6} {1.8 1.9}}
+test btree-3.2 {inserting with tags} -body {
setup
.t insert 1.15 YYY
list [.t tag ranges x] [.t tag ranges y]
-} {{1.1 1.2 1.5 1.13 2.2 2.6} {1.5 1.6}}
-test btree-3.3 {inserting with tags} {
+} -result {{1.1 1.2 1.5 1.13 2.2 2.6} {1.5 1.6}}
+test btree-3.3 {inserting with tags} -body {
setup
.t insert 1.7 ZZZZ
list [.t tag ranges x] [.t tag ranges y]
-} {{1.1 1.2 1.5 1.17 2.2 2.6} {1.5 1.6}}
-test btree-3.4 {inserting with tags} {
+} -result {{1.1 1.2 1.5 1.17 2.2 2.6} {1.5 1.6}}
+test btree-3.4 {inserting with tags} -body {
setup
.t insert 1.7 \n\n
list [.t tag ranges x] [.t tag ranges y]
-} {{1.1 1.2 1.5 3.6 4.2 4.6} {1.5 1.6}}
-test btree-3.5 {inserting with tags} {
+} -result {{1.1 1.2 1.5 3.6 4.2 4.6} {1.5 1.6}}
+test btree-3.5 {inserting with tags} -body {
setup
.t insert 1.5 A\n
list [.t tag ranges x] [.t tag ranges y]
-} {{1.1 1.2 2.0 2.8 3.2 3.6} {2.0 2.1}}
-test btree-3.6 {inserting with tags} {
+} -result {{1.1 1.2 2.0 2.8 3.2 3.6} {2.0 2.1}}
+test btree-3.6 {inserting with tags} -body {
setup
.t insert 1.13 A\n
list [.t tag ranges x] [.t tag ranges y]
-} {{1.1 1.2 1.5 1.13 3.2 3.6} {1.5 1.6}}
+} -result {{1.1 1.2 1.5 1.13 3.2 3.6} {1.5 1.6}}
+
-test btree-4.1 {deleting with tags} {
+test btree-4.1 {deleting with tags} -body {
setup
.t delete 1.6 1.9
list [.t tag ranges x] [.t tag ranges y]
-} {{1.1 1.2 1.5 1.10 2.2 2.6} {1.5 1.6}}
-test btree-4.2 {deleting with tags} {
+} -result {{1.1 1.2 1.5 1.10 2.2 2.6} {1.5 1.6}}
+test btree-4.2 {deleting with tags} -body {
setup
.t delete 1.1 2.3
list [.t tag ranges x] [.t tag ranges y]
-} {{1.1 1.4} {}}
-test btree-4.3 {deleting with tags} {
+} -result {{1.1 1.4} {}}
+test btree-4.3 {deleting with tags} -body {
setup
.t delete 1.4 2.1
list [.t tag ranges x] [.t tag ranges y]
-} {{1.1 1.2 1.5 1.9} {}}
-test btree-4.4 {deleting with tags} {
+} -result {{1.1 1.2 1.5 1.9} {}}
+test btree-4.4 {deleting with tags} -body {
setup
.t delete 1.14 2.1
list [.t tag ranges x] [.t tag ranges y]
-} {{1.1 1.2 1.5 1.13 1.15 1.19} {1.5 1.6}}
-test btree-4.5 {deleting with tags} {
+} -result {{1.1 1.2 1.5 1.13 1.15 1.19} {1.5 1.6}}
+test btree-4.5 {deleting with tags} -body {
setup
.t delete 1.0 2.10
list [.t tag ranges x] [.t tag ranges y]
-} {{} {}}
-test btree-4.6 {deleting with tags} {
+} -result {{} {}}
+test btree-4.6 {deleting with tags} -body {
setup
.t delete 1.0 1.5
list [.t tag ranges x] [.t tag ranges y]
-} {{1.0 1.8 2.2 2.6} {1.0 1.1}}
-test btree-4.7 {deleting with tags} {
+} -result {{1.0 1.8 2.2 2.6} {1.0 1.1}}
+test btree-4.7 {deleting with tags} -body {
setup
.t delete 1.6 1.9
list [.t tag ranges x] [.t tag ranges y]
-} {{1.1 1.2 1.5 1.10 2.2 2.6} {1.5 1.6}}
-test btree-4.8 {deleting with tags} {
+} -result {{1.1 1.2 1.5 1.10 2.2 2.6} {1.5 1.6}}
+test btree-4.8 {deleting with tags} -body {
setup
.t delete 1.5 1.13
list [.t tag ranges x] [.t tag ranges y]
-} {{1.1 1.2 2.2 2.6} {}}
+} -result {{1.1 1.2 2.2 2.6} {}}
-set bigText1 {}
-for {set i 0} {$i < 10} {incr i} {
- append bigText1 "Line $i\n"
-}
-set bigText2 {}
-for {set i 0} {$i < 200} {incr i} {
- append bigText2 "Line $i\n"
-}
-test btree-5.1 {very large inserts, with tags} {
+
+test btree-5.1 {very large inserts, with tags} -setup {
+ set bigText1 {}
+ for {set i 0} {$i < 10} {incr i} {
+ append bigText1 "Line $i\n"
+ }
+} -body {
setup
.t insert 1.0 $bigText1
list [.t tag ranges x] [.t tag ranges y]
-} {{11.1 11.2 11.5 11.13 12.2 12.6} {11.5 11.6}}
-test btree-5.2 {very large inserts, with tags} {
+} -result {{11.1 11.2 11.5 11.13 12.2 12.6} {11.5 11.6}}
+test btree-5.2 {very large inserts, with tags} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
setup
.t insert 1.2 $bigText2
list [.t tag ranges x] [.t tag ranges y]
-} {{1.1 1.2 201.3 201.11 202.2 202.6} {201.3 201.4}}
-test btree-5.3 {very large inserts, with tags} {
+} -result {{1.1 1.2 201.3 201.11 202.2 202.6} {201.3 201.4}}
+test btree-5.3 {very large inserts, with tags} -body {
setup
for {set i 0} {$i < 200} {incr i} {
- .t insert 1.8 "longer line $i\n"
+ .t insert 1.8 "longer line $i\n"
}
- list [.t tag ranges x] [.t tag ranges y] [.t get 1.0 1.100] [.t get 198.0 198.100]
-} {{1.1 1.2 1.5 201.5 202.2 202.6} {1.5 1.6} {Text forlonger line 199} {longer line 2}}
+ list [.t tag ranges x] [.t tag ranges y] [.t get 1.0 1.100] \
+ [.t get 198.0 198.100]
+} -result {{1.1 1.2 1.5 201.5 202.2 202.6} {1.5 1.6} {Text forlonger line 199} {longer line 2}}
-test btree-6.1 {very large deletes, with tags} {
+
+test btree-6.1 {very large deletes, with tags} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
setup
.t insert 1.1 $bigText2
.t delete 1.2 201.2
list [.t tag ranges x] [.t tag ranges y]
-} {{1.4 1.12 2.2 2.6} {1.4 1.5}}
-test btree-6.2 {very large deletes, with tags} {
+} -result {{1.4 1.12 2.2 2.6} {1.4 1.5}}
+test btree-6.2 {very large deletes, with tags} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
setup
.t insert 1.1 $bigText2
for {set i 0} {$i < 200} {incr i} {
- .t delete 1.2 2.2
+ .t delete 1.2 2.2
}
list [.t tag ranges x] [.t tag ranges y]
-} {{1.4 1.12 2.2 2.6} {1.4 1.5}}
-test btree-6.3 {very large deletes, with tags} {
+} -result {{1.4 1.12 2.2 2.6} {1.4 1.5}}
+test btree-6.3 {very large deletes, with tags} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
setup
.t insert 1.1 $bigText2
.t delete 2.3 10000.0
.t get 1.0 1000.0
-} {TLine 0
+} -result {TLine 0
Lin
}
-test btree-6.4 {very large deletes, with tags} {
+test btree-6.4 {very large deletes, with tags} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
setup
.t insert 1.1 $bigText2
for {set i 0} {$i < 100} {incr i} {
- .t delete 30.0 31.0
+ .t delete 30.0 31.0
}
list [.t tag ranges x] [.t tag ranges y]
-} {{101.0 101.1 101.4 101.12 102.2 102.6} {101.4 101.5}}
-test btree-6.5 {very large deletes, with tags} {
+} -result {{101.0 101.1 101.4 101.12 102.2 102.6} {101.4 101.5}}
+test btree-6.5 {very large deletes, with tags} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
setup
.t insert 1.1 $bigText2
for {set i 0} {$i < 100} {incr i} {
- set j [expr $i+2]
- set k [expr 1+2*$i]
- .t tag add x $j.1 $j.3
- .t tag add y $k.1 $k.6
+ set j [expr $i+2]
+ set k [expr 1+2*$i]
+ .t tag add x $j.1 $j.3
+ .t tag add y $k.1 $k.6
}
.t delete 2.0 200.0
list [.t tag ranges x] [.t tag ranges y]
-} {{3.0 3.1 3.4 3.12 4.2 4.6} {1.1 1.6 3.4 3.5}}
-test btree-6.6 {very large deletes, with tags} {
+} -result {{3.0 3.1 3.4 3.12 4.2 4.6} {1.1 1.6 3.4 3.5}}
+test btree-6.6 {very large deletes, with tags} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
setup
.t insert 1.1 $bigText2
for {set i 0} {$i < 100} {incr i} {
- set j [expr $i+2]
- set k [expr 1+2*$i]
- .t tag add x $j.1 $j.3
- .t tag add y $k.1 $k.6
+ set j [expr $i+2]
+ set k [expr 1+2*$i]
+ .t tag add x $j.1 $j.3
+ .t tag add y $k.1 $k.6
}
for {set i 199} {$i >= 2} {incr i -1} {
- .t delete $i.0 [expr $i+1].0
+ .t delete $i.0 [expr $i+1].0
}
list [.t tag ranges x] [.t tag ranges y]
-} {{3.0 3.1 3.4 3.12 4.2 4.6} {1.1 1.6 3.4 3.5}}
-
-.t delete 1.0 end
-.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
-set i 1
-foreach check {
- {1.3 1.6 1.7 2.0 {1.3 1.6 1.7 2.0}}
- {1.3 1.6 1.6 2.0 {1.3 2.0}}
- {1.3 1.6 1.4 2.0 {1.3 2.0}}
- {2.0 4.3 1.4 1.10 {1.4 1.10 2.0 4.3}}
- {2.0 4.3 1.4 1.end {1.4 1.19 2.0 4.3}}
- {2.0 4.3 1.4 2.0 {1.4 4.3}}
- {2.0 4.3 1.4 3.0 {1.4 4.3}}
- {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.1 4.2 {1.1 4.2}}
- {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.3 4.2 {1.2 4.2}}
- {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.1 3.0 {1.1 4.0}}
- {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.2 3.0 {1.2 4.0}}
-} {
- test btree-7.$i {tag addition and removal} {
- .t tag remove x 1.0 end
- while {[llength $check] > 2} {
- .t tag add x [lindex $check 0] [lindex $check 1]
- set check [lrange $check 2 end]
- }
- .t tag ranges x
- } [lindex $check [expr [llength $check]-1]]
- incr i
-}
+} -result {{3.0 3.1 3.4 3.12 4.2 4.6} {1.1 1.6 3.4 3.5}}
+
+
+test btree-7.1 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {1.3 1.6 1.7 2.0}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.3 1.6 1.7 2.0}
+test btree-7.2 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {1.3 1.6 1.6 2.0}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.3 2.0}
+test btree-7.3 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {1.3 1.6 1.4 2.0}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.3 2.0}
+test btree-7.4 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {2.0 4.3 1.4 1.10}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.4 1.10 2.0 4.3}
+test btree-7.5 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {2.0 4.3 1.4 1.end}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.4 1.19 2.0 4.3}
+test btree-7.6 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {2.0 4.3 1.4 2.0}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.4 4.3}
+test btree-7.7 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {2.0 4.3 1.4 3.0}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.4 4.3}
+test btree-7.8 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.1 4.2}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.1 4.2}
+test btree-7.9 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.3 4.2}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.2 4.2}
+test btree-7.10 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.1 3.0}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.1 4.0}
+test btree-7.11 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.2 3.0}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.2 4.0}
-test btree-8.1 {tag addition and removal, weird ranges} {
+
+test btree-8.1 {tag addition and removal, weird ranges} -body {
.t delete 1.0 100000.0
.t tag delete x
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 0.0 1.3
.t tag ranges x
-} {1.0 1.3}
-test btree-8.2 {tag addition and removal, weird ranges} {
+} -result {1.0 1.3}
+test btree-8.2 {tag addition and removal, weird ranges} -body {
.t delete 1.0 100000.0
.t tag delete x
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 1.40 2.4
.t tag ranges x
-} {1.19 2.4}
-test btree-8.3 {tag addition and removal, weird ranges} {
+} -result {1.19 2.4}
+test btree-8.3 {tag addition and removal, weird ranges} -body {
.t delete 1.0 100000.0
.t tag delete x
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 4.40 4.41
.t tag ranges x
-} {}
-test btree-8.4 {tag addition and removal, weird ranges} {
+} -result {}
+test btree-8.4 {tag addition and removal, weird ranges} -body {
.t delete 1.0 100000.0
.t tag delete x
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 5.1 5.2
.t tag ranges x
-} {}
-test btree-8.5 {tag addition and removal, weird ranges} {
+} -result {}
+test btree-8.5 {tag addition and removal, weird ranges} -body {
.t delete 1.0 100000.0
.t tag delete x
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 1.1 9.0
.t tag ranges x
-} {1.1 5.0}
-test btree-8.6 {tag addition and removal, weird ranges} {
+} -result {1.1 5.0}
+test btree-8.6 {tag addition and removal, weird ranges} -body {
.t delete 1.0 100000.0
.t tag delete x
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 1.1 1.90
.t tag ranges x
-} {1.1 1.19}
-test btree-8.7 {tag addition and removal, weird ranges} {
+} -result {1.1 1.19}
+test btree-8.7 {tag addition and removal, weird ranges} -body {
.t delete 1.0 100000.0
.t tag delete x
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 1.1 4.90
.t tag ranges x
-} {1.1 4.17}
-test btree-8.8 {tag addition and removal, weird ranges} {
+} -result {1.1 4.17}
+test btree-8.8 {tag addition and removal, weird ranges} -body {
.t delete 1.0 100000.0
.t tag delete x
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 3.0 3.0
.t tag ranges x
-} {}
+} -result {}
+
-test btree-9.1 {tag names} {
+test btree-9.1 {tag names} -body {
setup
.t tag names
-} {sel x y}
-test btree-9.2 {tag names} {
+} -result {sel x y}
+test btree-9.2 {tag names} -body {
setup
.t tag add tag1 1.8
.t tag add tag2 1.8
.t tag add tag3 1.7 1.9
.t tag names 1.8
-} {x tag1 tag2 tag3}
-test btree-9.3 {lots of tag names} {
+} -result {x tag1 tag2 tag3}
+test btree-9.3 {lots of tag names} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
setup
.t insert 1.2 $bigText2
foreach i {tag1 foo ThisOne {x space} q r s t} {
- .t tag add $i 150.2
+ .t tag add $i 150.2
}
foreach i {u tagA tagB tagC and more {$} \{} {
- .t tag add $i 150.1 150.3
+ .t tag add $i 150.1 150.3
}
.t tag names 150.2
-} {tag1 foo ThisOne {x space} q r s t u tagA tagB tagC and more {$} \{}
-test btree-9.4 {lots of tag names} {
+} -result {tag1 foo ThisOne {x space} q r s t u tagA tagB tagC and more {$} \{}
+test btree-9.4 {lots of tag names} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
setup
.t insert 1.2 $bigText2
.t tag delete tag1 foo ThisOne more {x space} q r s t u
.t tag delete tagA tagB tagC and {$} \{ more
foreach i {tag1 foo ThisOne more {x space} q r s t} {
- .t tag add $i 150.2
+ .t tag add $i 150.2
}
foreach i {foo ThisOne u tagA tagB tagC and more {$} \{} {
- .t tag add $i 150.4
+ .t tag add $i 150.4
}
.t tag delete tag1 more q r tagA
.t tag names 150.2
-} {foo ThisOne {x space} s t}
+} -result {foo ThisOne {x space} s t}
-proc msetup {} {
- .t delete 1.0 100000.0
- .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
- .t mark set m1 1.2
- .t mark set l1 1.2
- .t mark gravity l1 left
- .t mark set next 1.6
- .t mark set x 1.6
- .t mark set m2 2.0
- .t mark set m3 2.100
- .t tag add x 1.3 1.8
-}
-test btree-10.1 {basic mark facilities} {
+
+test btree-10.1 {basic mark facilities} -body {
msetup
list [lsort [.t mark names]] [.t index m1] [.t index m2] [.t index m3]
-} {{current insert l1 m1 m2 m3 next x} 1.2 2.0 2.11}
-test btree-10.2 {basic mark facilities} {
+} -result {{current insert l1 m1 m2 m3 next x} 1.2 2.0 2.11}
+test btree-10.2 {basic mark facilities} -body {
msetup
.t mark unset m2
lsort [.t mark names]
-} {current insert l1 m1 m3 next x}
-test btree-10.3 {basic mark facilities} {
+} -result {current insert l1 m1 m3 next x}
+test btree-10.3 {basic mark facilities} -body {
msetup
.t mark set m2 1.8
list [lsort [.t mark names]] [.t index m1] [.t index m2] [.t index m3]
-} {{current insert l1 m1 m2 m3 next x} 1.2 1.8 2.11}
+} -result {{current insert l1 m1 m2 m3 next x} 1.2 1.8 2.11}
-test btree-11.1 {marks and inserts} {
+
+test btree-11.1 {marks and inserts} -body {
msetup
.t insert 1.1 abcde
list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
-} {1.7 1.7 1.11 1.11 2.0 2.11}
-test btree-11.2 {marks and inserts} {
+} -result {1.7 1.7 1.11 1.11 2.0 2.11}
+test btree-11.2 {marks and inserts} -body {
msetup
.t insert 1.2 abcde
list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
-} {1.2 1.7 1.11 1.11 2.0 2.11}
-test btree-11.3 {marks and inserts} {
+} -result {1.2 1.7 1.11 1.11 2.0 2.11}
+test btree-11.3 {marks and inserts} -body {
msetup
.t insert 1.3 abcde
list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
-} {1.2 1.2 1.11 1.11 2.0 2.11}
-test btree-11.4 {marks and inserts} {
+} -result {1.2 1.2 1.11 1.11 2.0 2.11}
+test btree-11.4 {marks and inserts} -body {
msetup
.t insert 1.1 ab\n\ncde
list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
-} {3.4 3.4 3.8 3.8 4.0 4.11}
-test btree-11.5 {marks and inserts} {
+} -result {3.4 3.4 3.8 3.8 4.0 4.11}
+test btree-11.5 {marks and inserts} -body {
msetup
.t insert 1.4 ab\n\ncde
list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
-} {1.2 1.2 3.5 3.5 4.0 4.11}
-test btree-11.6 {marks and inserts} {
+} -result {1.2 1.2 3.5 3.5 4.0 4.11}
+test btree-11.6 {marks and inserts} -body {
msetup
.t insert 1.7 ab\n\ncde
list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
-} {1.2 1.2 1.6 1.6 4.0 4.11}
+} -result {1.2 1.2 1.6 1.6 4.0 4.11}
+
-test btree-12.1 {marks and deletes} {
+test btree-12.1 {marks and deletes} -body {
msetup
.t delete 1.3 1.5
list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
-} {1.2 1.2 1.4 1.4 2.0 2.11}
-test btree-12.2 {marks and deletes} {
+} -result {1.2 1.2 1.4 1.4 2.0 2.11}
+test btree-12.2 {marks and deletes} -body {
msetup
.t delete 1.3 1.8
list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
-} {1.2 1.2 1.3 1.3 2.0 2.11}
-test btree-12.3 {marks and deletes} {
+} -result {1.2 1.2 1.3 1.3 2.0 2.11}
+test btree-12.3 {marks and deletes} -body {
msetup
.t delete 1.2 1.8
list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
-} {1.2 1.2 1.2 1.2 2.0 2.11}
-test btree-12.4 {marks and deletes} {
+} -result {1.2 1.2 1.2 1.2 2.0 2.11}
+test btree-12.4 {marks and deletes} -body {
msetup
.t delete 1.1 1.8
list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
-} {1.1 1.1 1.1 1.1 2.0 2.11}
-test btree-12.5 {marks and deletes} {
+} -result {1.1 1.1 1.1 1.1 2.0 2.11}
+test btree-12.5 {marks and deletes} -body {
msetup
.t delete 1.5 3.1
list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
-} {1.2 1.2 1.5 1.5 1.5 1.5}
-test btree-12.6 {marks and deletes} {
+} -result {1.2 1.2 1.5 1.5 1.5 1.5}
+test btree-12.6 {marks and deletes} -body {
msetup
.t mark set m2 4.5
.t delete 1.5 4.1
list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
-} {1.2 1.2 1.5 1.5 1.9 1.5}
-test btree-12.7 {marks and deletes} {
+} -result {1.2 1.2 1.5 1.5 1.9 1.5}
+test btree-12.7 {marks and deletes} -body {
msetup
.t mark set m2 4.5
.t mark set m3 4.5
.t mark set m1 4.7
.t delete 1.5 4.1
list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
-} {1.2 1.11 1.5 1.5 1.9 1.9}
+} -result {1.2 1.11 1.5 1.5 1.9 1.9}
-destroy .t
-text .t
-test btree-13.1 {tag searching} {
+
+test btree-13.1 {tag searching} -setup {
.t delete 1.0 100000.0
+} -body {
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag next x 2.2 2.1
-} {}
-test btree-13.2 {tag searching} {
+} -result {}
+test btree-13.2 {tag searching} -setup {
.t delete 1.0 100000.0
+} -body {
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 2.2 2.4
.t tag next x 2.2 2.3
-} {2.2 2.4}
-test btree-13.3 {tag searching} {
+} -result {2.2 2.4}
+test btree-13.3 {tag searching} -setup {
.t delete 1.0 100000.0
+} -body {
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 2.2 2.4
.t tag next x 2.3 2.6
-} {}
-test btree-13.4 {tag searching} {
+} -result {}
+test btree-13.4 {tag searching} -setup {
.t delete 1.0 100000.0
+} -body {
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 2.5 2.8
.t tag next x 2.1 2.6
-} {2.5 2.8}
-test btree-13.5 {tag searching} {
+} -result {2.5 2.8}
+test btree-13.5 {tag searching} -setup {
.t delete 1.0 100000.0
+} -body {
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 2.5 2.8
.t tag next x 2.1 2.5
-} {}
-test btree-13.6 {tag searching} {
+} -result {}
+test btree-13.6 {tag searching} -setup {
.t delete 1.0 100000.0
+} -body {
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 2.1 2.4
.t tag next x 2.5 2.8
-} {}
-test btree-13.7 {tag searching} {
+} -result {}
+test btree-13.7 {tag searching} -setup {
.t delete 1.0 100000.0
+} -body {
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 2.5 2.8
.t tag next x 2.1 2.4
-} {}
-test btree-13.8 {tag searching} {
+} -result {}
+test btree-13.8 {tag searching} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
setup
.t insert 1.2 $bigText2
.t tag add x 190.3 191.2
.t tag next x 3.5
-} {190.3 191.2}
+} -result {190.3 191.2}
+destroy .t
+
-test btree-14.1 {check tag presence} {
+test btree-14.1 {check tag presence} -setup {
+ destroy .t
+ text .t
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
setup
.t insert 1.2 $bigText2
.t tag add x 3.5 3.7
@@ -656,242 +862,371 @@ test btree-14.1 {check tag presence} {
.t tag add b 7.5
.t tag add b 140.3
for {set i 120} {$i < 160} {incr i} {
- .t tag add c $i.4
+ .t tag add c $i.4
}
foreach i {a1 a2 a3 a4 a5 a6 a7 a8 a9 10 a11 a12 a13} {
- .t tag add $i 122.2
+ .t tag add $i 122.2
}
.t tag add x 141.3
.t tag names 141.1
-} {x y z}
+} -cleanup {
+ destroy .t
+} -result {x y z}
+
-test btree-15.1 {rebalance with empty node} {
- catch {destroy .t}
+test btree-15.1 {rebalance with empty node} -setup {
+ destroy .t
+} -body {
text .t
.t debug 1
.t insert end "1\n2\n3\n4\n5\n6\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17\n18\n19\n20\n21\n22\n23"
.t delete 6.0 12.0
.t get 1.0 end
-} "1\n2\n3\n4\n5\n12\n13\n14\n15\n16\n17\n18\n19\n20\n21\n22\n23\n"
+} -cleanup {
+ destroy .t
+} -result "1\n2\n3\n4\n5\n12\n13\n14\n15\n16\n17\n18\n19\n20\n21\n22\n23\n"
-proc setupBig {} {
- .t delete 1.0 end
- .t tag delete x y
- .t tag configure x -foreground blue
- .t tag configure y -underline true
- # Create a Btree with 2002 lines (2000 + already existing + phantom at end)
- # This generates a level 3 node with 9 children
- # Most level 2 nodes cover 216 lines and have 6 children, except the last
- # level 2 node covers 274 lines and has 7 children.
- # Most level 1 nodes cover 36 lines and have 6 children, except the
- # rightmost node has 58 lines and 9 children.
- # Level 2: 2002 = 8*216 + 274
- # Level 1: 2002 = 54*36 + 58
- # Level 0: 2002 = 332*6 + 10
- for {set i 0} {$i < 2000} {incr i} {
- append x "Line $i abcd efgh ijkl\n"
- }
- .t insert insert $x
- .t debug 1
-}
-test btree-16.1 {add tag does not push root above level 0} {
- catch {destroy .t}
+test btree-16.1 {add tag does not push root above level 0} -setup {
+ destroy .t
text .t
+} -body {
setupBig
+ .t debug 0
.t tag add x 1.1 1.10
.t tag add x 5.1 5.10
.t tag ranges x
-} {1.1 1.10 5.1 5.10}
-test btree-16.2 {add tag pushes root up to level 1 node} {
- catch {destroy .t}
+} -cleanup {
+ destroy .t
+} -result {1.1 1.10 5.1 5.10}
+test btree-16.2 {add tag pushes root up to level 1 node} -setup {
+ destroy .t
text .t
- .t debug 1
+} -body {
setupBig
.t tag add x 1.1 1.10
.t tag add x 8.1 8.10
.t tag ranges x
-} {1.1 1.10 8.1 8.10}
-test btree-16.3 {add tag pushes root up to level 2 node} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {1.1 1.10 8.1 8.10}
+test btree-16.3 {add tag pushes root up to level 2 node} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
.t tag add x 8.1 9.10
.t tag add x 180.1 180.end
.t tag ranges x
-} {8.1 9.10 180.1 180.23}
-test btree-16.4 {add tag pushes root up to level 3 node} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {8.1 9.10 180.1 180.23}
+test btree-16.4 {add tag pushes root up to level 3 node} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
.t tag add y 1.1 2000.0
.t tag add x 1.1 8.10
.t tag add x 180.end 217.0
list [.t tag ranges x] [.t tag ranges y]
-} {{1.1 8.10 180.23 217.0} {1.1 2000.0}}
-test btree-16.5 {add tag doesn't push root up} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {{1.1 8.10 180.23 217.0} {1.1 2000.0}}
+test btree-16.5 {add tag doesn't push root up} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
.t tag add x 1.1 8.10
.t tag add x 2000.0 2000.3
.t tag add x 180.end 217.0
.t tag ranges x
-} {1.1 8.10 180.23 217.0 2000.0 2000.3}
-test btree-16.6 {two node splits at once pushes root up} {
- .t delete 1.0 end
+} -cleanup {
+ destroy .t
+} -result {1.1 8.10 180.23 217.0 2000.0 2000.3}
+test btree-16.6 {two node splits at once pushes root up} -setup {
+ destroy .t
+ text .t
+} -body {
for {set i 1} {$i < 10} {incr i} {
- .t insert end "Line $i\n"
+ .t insert end "Line $i\n"
}
.t tag add x 8.0 8.end
.t tag add y 9.0 end
set x {}
for {} {$i < 50} {incr i} {
- append x "Line $i\n"
+ append x "Line $i\n"
}
.t insert end $x y
list [.t tag ranges x] [.t tag ranges y]
-} {{8.0 8.6} {9.0 51.0}}
+} -cleanup {
+ destroy .t
+} -result {{8.0 8.6} {9.0 51.0}}
# The following find bugs in the SearchStart procedures
-test btree-16.7 {Partial tag remove from before first range} {
- .t tag remove x 1.0 end
+test btree-16.7 {Partial tag remove from before first range} -setup {
+ destroy .t
+ text .t
+ for {set i 1} {$i < 10} {incr i} {
+ .t insert end "Line $i\n"
+ }
+} -body {
.t tag add x 2.0 2.6
.t tag remove x 1.0 2.0
.t tag ranges x
-} {2.0 2.6}
-test btree-16.8 {Partial tag remove from before first range} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {2.0 2.6}
+test btree-16.8 {Partial tag remove from before first range} -setup {
+ destroy .t
+ text .t
+ for {set i 1} {$i < 10} {incr i} {
+ .t insert end "Line $i\n"
+ }
+} -body {
.t tag add x 2.0 2.6
.t tag remove x 1.0 2.1
.t tag ranges x
-} {2.1 2.6}
-test btree-16.9 {Partial tag remove from before first range} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {2.1 2.6}
+test btree-16.9 {Partial tag remove from before first range} -setup {
+ destroy .t
+ text .t
+ for {set i 1} {$i < 10} {incr i} {
+ .t insert end "Line $i\n"
+ }
+} -body {
.t tag add x 2.0 2.6
.t tag remove x 1.0 2.3
.t tag ranges x
-} {2.3 2.6}
-test btree-16.10 {Partial tag remove from before first range} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {2.3 2.6}
+test btree-16.10 {Partial tag remove from before first range} -setup {
+ destroy .t
+ text .t
+ for {set i 1} {$i < 10} {incr i} {
+ .t insert end "Line $i\n"
+ }
+} -body {
.t tag add x 1.0 2.6
.t tag remove x 1.0 2.5
.t tag ranges x
-} {2.5 2.6}
-test btree-16.11 {StartSearchBack boundary case} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {2.5 2.6}
+test btree-16.11 {StartSearchBack boundary case} -setup {
+ destroy .t
+ text .t
+ for {set i 1} {$i < 10} {incr i} {
+ .t insert end "Line $i\n"
+ }
+} -body {
.t tag add x 1.3 1.4
.t tag prevr x 2.0 1.4
-} {}
-test btree-16.12 {StartSearchBack boundary case} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {}
+test btree-16.12 {StartSearchBack boundary case} -setup {
+ destroy .t
+ text .t
+ for {set i 1} {$i < 10} {incr i} {
+ .t insert end "Line $i\n"
+ }
+} -body {
.t tag add x 1.3 1.4
.t tag prevr x 2.0 1.3
-} {1.3 1.4}
-test btree-16.13 {StartSearchBack boundary case} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {1.3 1.4}
+test btree-16.13 {StartSearchBack boundary case} -setup {
+ destroy .t
+ text .t
+ for {set i 1} {$i < 10} {incr i} {
+ .t insert end "Line $i\n"
+ }
+} -body {
.t tag add x 1.0 1.4
.t tag prevr x 1.3
-} {1.0 1.4}
+} -cleanup {
+ destroy .t
+} -result {1.0 1.4}
-test btree-17.1 {remove tag does not push root down} {
- catch {destroy .t}
+test btree-17.1 {remove tag does not push root down} -setup {
+ destroy .t
text .t
+} -body {
.t debug 0
setupBig
.t tag add x 1.1 5.10
.t tag remove x 3.1 5.end
.t tag ranges x
-} {1.1 3.1}
-test btree-17.2 {remove tag pushes root from level 1 to level 0} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {1.1 3.1}
+test btree-17.2 {remove tag pushes root from level 1 to level 0} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
.t tag add x 1.1 8.10
.t tag remove x 3.1 end
.t tag ranges x
-} {1.1 3.1}
-test btree-17.3 {remove tag pushes root from level 2 to level 1} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {1.1 3.1}
+test btree-17.3 {remove tag pushes root from level 2 to level 1} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
.t tag add x 1.1 180.10
.t tag remove x 35.1 end
.t tag ranges x
-} {1.1 35.1}
-test btree-17.4 {remove tag doesn't change level 2} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {1.1 35.1}
+test btree-17.4 {remove tag doesn't change level 2} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
.t tag add x 1.1 180.10
.t tag remove x 35.1 180.0
.t tag ranges x
-} {1.1 35.1 180.0 180.10}
-test btree-17.5 {remove tag pushes root from level 3 to level 0} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {1.1 35.1 180.0 180.10}
+test btree-17.5 {remove tag pushes root from level 3 to level 0} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
.t tag add x 1.1 1.10
.t tag add x 2000.1 2000.10
.t tag remove x 1.0 2000.0
.t tag ranges x
-} {2000.1 2000.10}
-test btree-17.6 {text deletion pushes root from level 3 to level 0} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {2000.1 2000.10}
+test btree-17.6 {text deletion pushes root from level 3 to level 0} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
.t tag add x 1.1 1.10
.t tag add x 2000.1 2000.10
.t delete 1.0 "1000.0 lineend +1 char"
.t tag ranges x
-} {1000.1 1000.10}
+} -cleanup {
+ destroy .t
+} -result {1000.1 1000.10}
-catch {destroy .t}
-text .t
-test btree-18.1 {tag search back, no tag} {
+
+test btree-18.1 {tag search back, no tag} -setup {
+ destroy .t
+ text .t
+} -body {
.t insert 1.0 "Line 1 abcd efgh ijkl\n"
.t tag prev x 1.1 1.1
-} {}
-test btree-18.2 {tag search back, start at existing range} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {}
+test btree-18.2 {tag search back, start at existing range} -setup {
+ destroy .t
+ text .t
+} -body {
+ .t insert 1.0 "Line 1 abcd efgh ijkl\n"
.t tag add x 1.1 1.4
.t tag add x 1.8 1.11
.t tag add x 1.16
.t tag prev x 1.1
-} {}
-test btree-18.3 {tag search back, end at existing range} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {}
+test btree-18.3 {tag search back, end at existing range} -setup {
+ destroy .t
+ text .t
+} -body {
+ .t insert 1.0 "Line 1 abcd efgh ijkl\n"
.t tag add x 1.1 1.4
.t tag add x 1.8 1.11
.t tag add x 1.16
.t tag prev x 1.3 1.1
-} {1.1 1.4}
-test btree-18.4 {tag search back, start within range} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {1.1 1.4}
+test btree-18.4 {tag search back, start within range} -setup {
+ destroy .t
+ text .t
+} -body {
+ .t insert 1.0 "Line 1 abcd efgh ijkl\n"
.t tag add x 1.1 1.4
.t tag add x 1.8 1.11
.t tag add x 1.16
.t tag prev x 1.10 1.0
-} {1.8 1.11}
-test btree-18.5 {tag search back, start at end of range} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {1.8 1.11}
+test btree-18.5 {tag search back, start at end of range} -setup {
+ destroy .t
+ text .t
+} -body {
+ .t insert 1.0 "Line 1 abcd efgh ijkl\n"
.t tag add x 1.1 1.4
.t tag add x 1.8 1.11
.t tag add x 1.16
list [.t tag prev x 1.4 1.0] [.t tag prev x 1.11 1.0]
-} {{1.1 1.4} {1.8 1.11}}
-test btree-18.6 {tag search back, start beyond range, same level 0 node} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {{1.1 1.4} {1.8 1.11}}
+test btree-18.6 {tag search back, start beyond range, same level 0 node} -setup {
+ destroy .t
+ text .t
+} -body {
+ .t insert 1.0 "Line 1 abcd efgh ijkl\n"
.t tag add x 1.1 1.4
.t tag add x 1.8 1.11
.t tag add x 1.16
.t tag prev x 3.0
-} {1.16 1.17}
-test btree-18.7 {tag search back, outside any range} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {1.16 1.17}
+test btree-18.7 {tag search back, outside any range} -setup {
+ destroy .t
+ text .t
+} -body {
+ .t insert 1.0 "Line 1 abcd efgh ijkl\n"
.t tag add x 1.1 1.4
.t tag add x 1.16
.t tag prev x 1.8 1.5
-} {}
-test btree-18.8 {tag search back, start at start of node boundary} {
+} -cleanup {
+ destroy .t
+} -result {}
+test btree-18.8 {tag search back, start at start of node boundary} -setup {
+ destroy .t
+ text .t
+} -body {
setupBig
- .t tag remove x 1.0 end
.t tag add x 2.5 2.8
.t tag prev x 19.0
-} {2.5 2.8}
-test btree-18.9 {tag search back, large complex btree spans} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {2.5 2.8}
+test btree-18.9 {tag search back, large complex btree spans} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
.t tag add x 1.3 1.end
.t tag add x 200.0 220.0
.t tag add x 500.0 520.0
list [.t tag prev x end] [.t tag prev x 433.0]
-} {{500.0 520.0} {200.0 220.0}}
-
-destroy .t
+} -cleanup {
+ destroy .t
+} -result {{500.0 520.0} {200.0 220.0}}
# cleanup
cleanupTests
diff --git a/tests/textImage.test b/tests/textImage.test
index bb5909c..24246cc 100644
--- a/tests/textImage.test
+++ b/tests/textImage.test
@@ -7,349 +7,445 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
+imageInit
# One time setup. Create a font to insure the tests are font metric invariant.
-
-catch {destroy .t}
+destroy .t
font create test_font -family courier -size 14
text .t -font test_font
destroy .t
-test textImage-1.1 {basic argument checking} {
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image} msg] $msg
-} {1 {wrong # args: should be ".t image option ?arg arg ...?"}}
-
-test textImage-1.2 {basic argument checking} {
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image c} msg] $msg
-} {1 {ambiguous option "c": must be cget, configure, create, or names}}
-
-test textImage-1.3 {cget argument checking} {
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image cget} msg] $msg
-} {1 {wrong # args: should be ".t image cget index option"}}
-
-test textImage-1.4 {cget argument checking} {
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image cget blurf -flurp} msg] $msg
-} {1 {bad text index "blurf"}}
-
-test textImage-1.5 {cget argument checking} {
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image cget 1.1 -flurp} msg] $msg
-} {1 {no embedded image at index "1.1"}}
-
-test textImage-1.6 {configure argument checking} {
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image configure } msg] $msg
-} {1 {wrong # args: should be ".t image configure index ?option value ...?"}}
-
-test textImage-1.7 {configure argument checking} {
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image configure blurf } msg] $msg
-} {1 {bad text index "blurf"}}
-
-test textImage-1.8 {configure argument checking} {
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image configure 1.1 } msg] $msg
-} {1 {no embedded image at index "1.1"}}
-
-test textImage-1.9 {create argument checking} {
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image create} msg] $msg
-} {1 {wrong # args: should be ".t image create index ?option value ...?"}}
-
-test textImage-1.10 {create argument checking} {
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image create blurf } msg] $msg
-} {1 {bad text index "blurf"}}
-
-test textImage-1.11 {basic argument checking} {
- catch {
- image create photo small -width 5 -height 5
- small put red -to 0 0 4 4
- }
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image create 1000.1000 -image small} msg] $msg
-} {0 small}
-
-test textImage-1.12 {names argument checking} {
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image names dates places} msg] $msg
-} {1 {wrong # args: should be ".t image names"}}
-
-
-test textImage-1.13 {names argument checking} {
- catch {
- image create photo small -width 5 -height 5
- small put red -to 0 0 4 4
- }
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- set result ""
- lappend result [.t image names]
- .t image create insert -image small
- lappend result [.t image names]
- .t image create insert -image small
- lappend result [.t image names]
- .t image create insert -image small -name little
- lappend result [.t image names]
-} {{} small {small#1 small} {small#1 small little}}
-
-test textImage-1.14 {basic argument checking} {
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image huh} msg] $msg
-} {1 {bad option "huh": must be cget, configure, create, or names}}
-
-test textImage-1.15 {align argument checking} {
- catch {
- image create photo small -width 5 -height 5
- small put red -to 0 0 4 4
- }
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image create end -image small -align wrong} msg] $msg
-} {1 {bad align "wrong": must be baseline, bottom, center, or top}}
-
-test textImage-1.16 {configure} {
- catch {
- image create photo small -width 5 -height 5
- small put red -to 0 0 4 4
- }
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- .t image create end -image small
- .t image configure small
-} {{-align {} {} center center} {-padx {} {} 0 0} {-pady {} {} 0 0} {-image {} {} {} small} {-name {} {} {} {}}}
-
-test textImage-1.17 {basic cget options} {
- catch {
- image create photo small -width 5 -height 5
- small put red -to 0 0 4 4
- }
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- .t image create end -image small
- set result ""
- foreach i {align padx pady image name} {
- lappend result $i:[.t image cget small -$i]
- }
- set result
-} {align:center padx:0 pady:0 image:small name:}
-
-test textImage-1.18 {basic configure options} {
- catch {
- image create photo small -width 5 -height 5
- small put red -to 0 0 4 4
- image create photo large -width 50 -height 50
- large put green -to 0 0 50 50
- }
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- .t image create end -image small
- set result ""
- foreach {option value} {align top padx 5 pady 7 image large name none} {
- .t image configure small -$option $value
- }
- update
- .t image configure small
-} {{-align {} {} center top} {-padx {} {} 0 5} {-pady {} {} 0 7} {-image {} {} {} large} {-name {} {} {} none}}
-
-test textImage-1.19 {basic image naming} {
- catch {
- image create photo small -width 5 -height 5
- small put red -to 0 0 4 4
- }
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- .t image create end -image small
- .t image create end -image small -name small
- .t image create end -image small -name small#6342
- .t image create end -image small -name small
- lsort [.t image names]
-} {small small#1 small#6342 small#6343}
-
-test textImage-2.1 {debug} {
- catch {
- image create photo small -width 5 -height 5
- small put red -to 0 0 4 4
- }
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- .t debug 1
- .t insert end front
- .t image create end -image small
- .t insert end back
- .t delete small
- .t image names
- .t debug 0
-} {}
-
-test textImage-3.1 {image change propagation} {
- catch {
- image create photo vary -width 5 -height 5
- small put red -to 0 0 4 4
- }
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- .t image create end -image vary -align top
- update
- set result ""
- lappend result base:[.t bbox vary]
- foreach i {10 20 40} {
- vary configure -width $i -height $i
- update
- lappend result $i:[.t bbox vary]
- }
- set result
-} {{base:0 0 5 5} {10:0 0 10 10} {20:0 0 20 20} {40:0 0 40 40}}
-
-test textImage-3.2 {delayed image management} {
- catch {
- image create photo small -width 5 -height 5
- small put red -to 0 0 4 4
- }
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- .t image create end -name test
- update
- set result ""
- lappend result [.t bbox test]
- .t image configure test -image small -align top
- update
- lappend result [.t bbox test]
-} {{} {0 0 5 5}}
+test textImage-1.1 {basic argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {wrong # args: should be ".t image option ?arg ...?"}
+
+test textImage-1.2 {basic argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image c
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {ambiguous option "c": must be cget, configure, create, or names}
+
+test textImage-1.3 {cget argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image cget
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {wrong # args: should be ".t image cget index option"}
+
+test textImage-1.4 {cget argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image cget blurf -flurp
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {bad text index "blurf"}
+
+test textImage-1.5 {cget argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image cget 1.1 -flurp
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {no embedded image at index "1.1"}
+
+test textImage-1.6 {configure argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image configure
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {wrong # args: should be ".t image configure index ?-option value ...?"}
+
+test textImage-1.7 {configure argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image configure blurf
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {bad text index "blurf"}
+
+test textImage-1.8 {configure argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image configure 1.1
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {no embedded image at index "1.1"}
+
+test textImage-1.9 {create argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {wrong # args: should be ".t image create index ?-option value ...?"}
+
+test textImage-1.10 {create argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create blurf
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {bad text index "blurf"}
+
+test textImage-1.11 {basic argument checking} -setup {
+ destroy .t
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create 1000.1000 -image small
+} -cleanup {
+ destroy .t
+ image delete small
+} -returnCodes ok -result {small}
+
+test textImage-1.12 {names argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image names dates places
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {wrong # args: should be ".t image names"}
+
+
+test textImage-1.13 {names argument checking} -setup {
+ destroy .t
+ set result ""
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ lappend result [.t image names]
+ .t image create insert -image small
+ lappend result [.t image names]
+ .t image create insert -image small
+ lappend result [lsort [.t image names]]
+ .t image create insert -image small -name little
+ lappend result [lsort [.t image names]]
+} -cleanup {
+ destroy .t
+ image delete small
+} -result {{} small {small small#1} {little small small#1}}
+
+test textImage-1.14 {basic argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image huh
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {bad option "huh": must be cget, configure, create, or names}
+
+test textImage-1.15 {align argument checking} -setup {
+ destroy .t
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create end -image small -align wrong
+} -cleanup {
+ destroy .t
+ image delete small
+} -returnCodes error -result {bad align "wrong": must be baseline, bottom, center, or top}
+
+test textImage-1.16 {configure} -setup {
+ destroy .t
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create end -image small
+ .t image configure small
+} -cleanup {
+ destroy .t
+ image delete small
+} -result {{-align {} {} center center} {-padx {} {} 0 0} {-pady {} {} 0 0} {-image {} {} {} small} {-name {} {} {} {}}}
+
+test textImage-1.17 {basic cget options} -setup {
+ destroy .t
+ set result ""
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create end -image small
+ foreach i {align padx pady image name} {
+ lappend result $i:[.t image cget small -$i]
+ }
+ return $result
+} -cleanup {
+ destroy .t
+ image delete small
+} -result {align:center padx:0 pady:0 image:small name:}
+
+test textImage-1.18 {basic configure options} -setup {
+ destroy .t
+ set result ""
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ image create photo large -width 50 -height 50
+ large put green -to 0 0 50 50
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create end -image small
+ foreach {option value} {align top padx 5 pady 7 image large name none} {
+ .t image configure small -$option $value
+ }
+ update
+ .t image configure small
+} -cleanup {
+ destroy .t
+ image delete small large
+} -result {{-align {} {} center top} {-padx {} {} 0 5} {-pady {} {} 0 7} {-image {} {} {} large} {-name {} {} {} none}}
+
+test textImage-1.19 {basic image naming} -setup {
+ destroy .t
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create end -image small
+ .t image create end -image small -name small
+ .t image create end -image small -name small#6342
+ .t image create end -image small -name small
+ lsort [.t image names]
+} -cleanup {
+ destroy .t
+ image delete small
+} -result {small small#1 small#6342 small#6343}
+
+test textImage-2.1 {debug} -setup {
+ destroy .t
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t debug 1
+ .t insert end front
+ .t image create end -image small
+ .t insert end back
+ .t delete small
+ .t image names
+ .t debug 0
+} -cleanup {
+ destroy .t
+ image delete small
+} -result {}
+
+
+test textImage-3.1 {image change propagation} -setup {
+ destroy .t
+ set result ""
+} -body {
+ catch {
+ image create photo vary -width 5 -height 5
+ vary put red -to 0 0 4 4
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create end -image vary -align top
+ update
+ lappend result base:[.t bbox vary]
+ foreach i {10 20 40} {
+ vary configure -width $i -height $i
+ update
+ lappend result $i:[.t bbox vary]
+ }
+ return $result
+} -cleanup {
+ destroy .t
+ image delete vary
+} -result {{base:0 0 5 5} {10:0 0 10 10} {20:0 0 20 20} {40:0 0 40 40}}
+
+# Fails in some environments (both in Linux and winXP)
+test textImage-3.2 {delayed image management} -setup {
+ destroy .t
+ set result ""
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create end -name test
+ update
+ lappend result [.t bbox test]
+ .t image configure test -image small -align top
+ update
+ lappend result [.t bbox test]
+} -cleanup {
+ destroy .t
+ image delete small
+} -result {{} {0 0 5 5}}
+
# some temporary random tests
-test textImage-4.1 {alignment checking - except baseline} {
+test textImage-4.1 {alignment checking - except baseline} -setup {
+ destroy .t
+ set result ""
+} -body {
catch {
- image create photo small -width 5 -height 5
- small put red -to 0 0 4 4
- image create photo large -width 50 -height 50
- large put green -to 0 0 50 50
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ image create photo large -width 50 -height 50
+ large put green -to 0 0 50 50
}
- catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image create end -image large
.t image create end -image small
.t insert end test
update
- set result ""
lappend result default:[.t bbox small]
foreach i {top bottom center} {
- .t image configure small -align $i
- update
- lappend result [.t image cget small -align]:[.t bbox small]
+ .t image configure small -align $i
+ update
+ lappend result [.t image cget small -align]:[.t bbox small]
}
- set result
-} {{default:50 22 5 5} {top:50 0 5 5} {bottom:50 45 5 5} {center:50 22 5 5}}
-
-test textImage-4.2 {alignment checking - baseline} {
+ return $result
+} -cleanup {
+ destroy .t
+ image delete small large
+} -result {{default:50 22 5 5} {top:50 0 5 5} {bottom:50 45 5 5} {center:50 22 5 5}}
+
+test textImage-4.2 {alignment checking - baseline} -setup {
+ destroy .t
+ set result ""
+} -body {
catch {
- image create photo small -width 5 -height 5
- small put red -to 0 0 4 4
- image create photo large -width 50 -height 50
- large put green -to 0 0 50 50
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ image create photo large -width 50 -height 50
+ large put green -to 0 0 50 50
}
- catch {destroy .t}
font create test_font2 -size 5
text .t -font test_font2 -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image create end -image large
.t image create end -image small -align baseline
.t insert end test
- set result ""
# Sizes larger than 25 can be too big and lead to a negative 'norm',
# at least on Windows XP with certain settings.
foreach size {10 15 20 25} {
- font configure test_font2 -size $size
- array set Metrics [font metrics test_font2]
- update
- foreach {x y w h} [.t bbox small] {}
- set norm [expr {
- (([image height large] - $Metrics(-linespace))/2
- + $Metrics(-ascent) - [image height small] - $y)
- }]
- lappend result "$size $norm"
+ font configure test_font2 -size $size
+ array set Metrics [font metrics test_font2]
+ update
+ foreach {x y w h} [.t bbox small] {}
+ set norm [expr {
+ (([image height large] - $Metrics(-linespace))/2
+ + $Metrics(-ascent) - [image height small] - $y)
+ }]
+ lappend result "$size $norm"
}
+ return $result
+} -cleanup {
+ destroy .t
+ image delete small large
font delete test_font2
unset Metrics
- set result
-} {{10 0} {15 0} {20 0} {25 0}}
+} -result {{10 0} {15 0} {20 0} {25 0}}
-test textImage-4.3 {alignment and padding checking} {fonts} {
+test textImage-4.3 {alignment and padding checking} -constraints {
+ fonts
+} -setup {
+ destroy .t
+ set result ""
+} -body {
catch {
- image create photo small -width 5 -height 5
- small put red -to 0 0 4 4
- image create photo large -width 50 -height 50
- large put green -to 0 0 50 50
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ image create photo large -width 50 -height 50
+ large put green -to 0 0 50 50
}
- catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image create end -image large
.t image create end -image small -padx 5 -pady 10
.t insert end test
update
- set result ""
lappend result default:[.t bbox small]
foreach i {top bottom center baseline} {
- .t image configure small -align $i
- update
- lappend result $i:[.t bbox small]
+ .t image configure small -align $i
+ update
+ lappend result $i:[.t bbox small]
}
- set result
-} {{default:55 22 5 5} {top:55 10 5 5} {bottom:55 35 5 5} {center:55 22 5 5} {baseline:55 22 5 5}}
+ return $result
+} -cleanup {
+ destroy .t
+ image delete small large
+} -result {{default:55 22 5 5} {top:55 10 5 5} {bottom:55 35 5 5} {center:55 22 5 5} {baseline:55 22 5 5}}
+
-test textImage-5.0 {peer widget images} {
+test textImage-5.1 {peer widget images} -setup {
+ destroy .t .tt
+} -body {
catch {
- image create photo small -width 5 -height 5
- small put red -to 0 0 4 4
- image create photo large -width 50 -height 50
- large put green -to 0 0 50 50
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ image create photo large -width 50 -height 50
+ large put green -to 0 0 50 50
}
- catch {destroy .t .tt}
pack [text .t]
toplevel .tt
pack [.t peer create .tt.t]
@@ -358,13 +454,19 @@ test textImage-5.0 {peer widget images} {
.t insert end test
update
destroy .t .tt
-} {}
+} -cleanup {
+ image delete small large
+} -result {}
# cleanup
-catch {destroy .t}
-foreach image [image names] {image delete $image}
+destroy .t
font delete test_font
+imageFinish
# cleanup
cleanupTests
return
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tests/textIndex.test b/tests/textIndex.test
index 28dc0df..c949b1f 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 dcec25d..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
- list [catch {.t tag bind x <FocusIn> script2} msg] $msg [.t tag bind x]
-} {1 {requested illegal events; only key, button, motion, enter, leave, and virtual events may be used} <Enter>}
-test textTag-3.6 {TkTextTagCmd - "bind" option} haveCourier12 {
+ .t tag bind x <FocusIn> script2
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {requested illegal events; only key, button, motion, enter, leave, and virtual events may be used}
+test textTag-3.6 {TkTextTagCmd - "bind" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag bind x <Enter> script1
+ catch {.t tag bind x <FocusIn> script2}
+ .t tag bind x
+} -cleanup {
+ .t tag delete x
+} -result {<Enter>}
+test textTag-3.7 {TkTextTagCmd - "bind" option} -constraints {
+ haveCourier12
+} -body {
.t tag delete x
.t tag bind x <Enter> script1
.t tag bind x <Leave> script2
.t tag bind x a xyzzy
list [lsort [.t tag bind x]] [.t tag bind x <Enter>] [.t tag bind x a]
-} {{<Enter> <Leave> a} script1 xyzzy}
-test textTag-3.7 {TkTextTagCmd - "bind" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {{<Enter> <Leave> a} script1 xyzzy}
+test textTag-3.8 {TkTextTagCmd - "bind" option} -constraints {
+ haveCourier12
+} -body {
.t tag delete x
.t tag bind x <Enter> script1
.t tag bind x <Enter> +script2
.t tag bind x <Enter>
-} {script1
+} -cleanup {
+ .t tag delete x
+} -result {script1
script2}
-test textTag-3.7a {TkTextTagCmd - "bind" option} haveCourier12 {
- .t tag delete x
- list [catch {.t tag bind x <Enter>} msg] $msg
-} {0 {}}
-test textTag-3.8 {TkTextTagCmd - "bind" option} haveCourier12 {
- .t tag delete x
- list [catch {.t tag bind x <} msg] $msg
-} {1 {no event type or button # or keysym}}
-
-test textTag-4.1 {TkTextTagCmd - "cget" option} haveCourier12 {
- list [catch {.t tag cget a} msg] $msg
-} {1 {wrong # args: should be ".t tag cget tagName option"}}
-test textTag-4.2 {TkTextTagCmd - "cget" option} haveCourier12 {
- list [catch {.t tag cget a b c} msg] $msg
-} {1 {wrong # args: should be ".t tag cget tagName option"}}
-test textTag-4.3 {TkTextTagCmd - "cget" option} haveCourier12 {
+test textTag-3.9 {TkTextTagCmd - "bind" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag bind x <Enter>
+} -cleanup {
+ .t tag delete x
+} -returnCodes ok -result {}
+test textTag-3.10 {TkTextTagCmd - "bind" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag bind x <
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {no event type or button # or keysym}
+
+
+test textTag-4.1 {TkTextTagCmd - "cget" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag cget a
+} -returnCodes error -result {wrong # args: should be ".t tag cget tagName option"}
+test textTag-4.2 {TkTextTagCmd - "cget" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag cget a b c
+} -returnCodes error -result {wrong # args: should be ".t tag cget tagName option"}
+test textTag-4.3 {TkTextTagCmd - "cget" option} -constraints {
+ haveCourier12
+} -body {
.t tag delete foo
- list [catch {.t tag cget foo bar} msg] $msg
-} {1 {tag "foo" isn't defined in text widget}}
-test textTag-4.4 {TkTextTagCmd - "cget" option} haveCourier12 {
- list [catch {.t tag cget sel bogus} msg] $msg
-} {1 {unknown option "bogus"}}
-test textTag-4.5 {TkTextTagCmd - "cget" option} haveCourier12 {
+ .t tag cget foo bar
+} -returnCodes error -result {tag "foo" isn't defined in text widget}
+test textTag-4.4 {TkTextTagCmd - "cget" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag cget sel bogus
+} -returnCodes error -result {unknown option "bogus"}
+test textTag-4.5 {TkTextTagCmd - "cget" option} -constraints {
+ haveCourier12
+} -body {
.t tag delete x
.t tag configure x -background red
- list [catch {.t tag cget x -background} msg] $msg
-} {0 red}
-
-test textTag-5.1 {TkTextTagCmd - "configure" option} haveCourier12 {
- list [catch {.t tag configure} msg] $msg
-} {1 {wrong # args: should be ".t tag configure tagName ?option? ?value? ?option value ...?"}}
-test textTag-5.2 {TkTextTagCmd - "configure" option} haveCourier12 {
- list [catch {.t tag configure x -foo} msg] $msg
-} {1 {unknown option "-foo"}}
-test textTag-5.3 {TkTextTagCmd - "configure" option} haveCourier12 {
- list [catch {.t tag configure x -background red -underline} msg] $msg
-} {1 {value for "-underline" missing}}
-test textTag-5.4 {TkTextTagCmd - "configure" option} haveCourier12 {
+ .t tag cget x -background
+} -cleanup {
+ .t tag delete x
+} -result {red}
+
+
+test textTag-5.1 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure
+} -returnCodes error -result {wrong # args: should be ".t tag configure tagName ?-option? ?value? ?-option value ...?"}
+test textTag-5.2 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -foo
+} -returnCodes error -result {unknown option "-foo"}
+test textTag-5.3 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -background red -underline
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {value for "-underline" missing}
+test textTag-5.4 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
.t tag delete x
.t tag configure x -underline yes
.t tag configure x -underline
-} {-underline {} {} {} yes}
-test textTag-5.5 {TkTextTagCmd - "configure" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {-underline {} {} {} yes}
+test textTag-5.5 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
.t tag delete x
.t tag configure x -overstrike on
.t tag cget x -overstrike
-} {on}
-test textTag-5.6 {TkTextTagCmd - "configure" option} haveCourier12 {
- list [catch {.t tag configure x -overstrike foo} msg] $msg
-} {1 {expected boolean value but got "foo"}}
-test textTag-5.7 {TkTextTagCmd - "configure" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {on}
+test textTag-5.6 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -overstrike foo
+} -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 "foo"}
+test textTag-5.7 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -underline stupid
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {expected boolean value but got "stupid"}
+test textTag-5.8 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
.t tag delete x
.t tag configure x -justify left
.t tag configure x -justify
-} {-justify {} {} {} left}
-test textTag-5.9 {TkTextTagCmd - "configure" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {-justify {} {} {} left}
+test textTag-5.9 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -justify bogus
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {bad justification "bogus": must be left, right, or center}
+test textTag-5.10 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
.t tag delete x
- list [catch {.t tag configure x -justify bogus} msg] $msg
-} {1 {bad justification "bogus": must be left, right, or center}}
-test textTag-5.10 {TkTextTagCmd - "configure" option} haveCourier12 {
+ .t tag configure x -justify fill
+} -cleanup {
.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 {
+} -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
- 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 {
+} -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
+} -returnCodes error -result {bad screen distance "1.0q"}
+test textTag-5.13 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
.t tag delete x
.t tag configure x -lmargin1 2 -lmargin2 4 -rmargin 5
list [.t tag configure x -lmargin1] [.t tag configure x -lmargin2] \
- [.t tag configure x -rmargin]
-} {{-lmargin1 {} {} {} 2} {-lmargin2 {} {} {} 4} {-rmargin {} {} {} 5}}
-test textTag-5.14 {TkTextTagCmd - "configure" option} haveCourier12 {
+ [.t tag configure x -rmargin]
+} -cleanup {
+ .t tag delete x
+} -result {{-lmargin1 {} {} {} 2} {-lmargin2 {} {} {} 4} {-rmargin {} {} {} 5}}
+test textTag-5.14 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -lmargin1 2.0x
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {bad screen distance "2.0x"}
+test textTag-5.15 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
.t tag delete x
- list [catch {.t tag configure x -lmargin1 2.0x} msg] $msg
-} {1 {bad screen distance "2.0x"}}
-test textTag-5.15 {TkTextTagCmd - "configure" option} haveCourier12 {
+ .t tag configure x -lmargin2 gorp
+} -cleanup {
.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 {
+} -returnCodes error -result {bad screen distance "gorp"}
+test textTag-5.16 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
.t tag delete x
- list [catch {.t tag configure x -rmargin 140.1.1} msg] $msg
-} {1 {bad screen distance "140.1.1"}}
+ .t tag configure x -rmargin 140.1.1
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {bad screen distance "140.1.1"}
.t tag delete x
-test textTag-5.17 {TkTextTagCmd - "configure" option} haveCourier12 {
+test textTag-5.17 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
.t tag delete x
.t tag configure x -spacing1 2 -spacing2 4 -spacing3 6
list [.t tag configure x -spacing1] [.t tag configure x -spacing2] \
- [.t tag configure x -spacing3]
-} {{-spacing1 {} {} {} 2} {-spacing2 {} {} {} 4} {-spacing3 {} {} {} 6}}
-test textTag-5.18 {TkTextTagCmd - "configure" option} haveCourier12 {
+ [.t tag configure x -spacing3]
+} -cleanup {
+ .t tag delete x
+} -result {{-spacing1 {} {} {} 2} {-spacing2 {} {} {} 4} {-spacing3 {} {} {} 6}}
+test textTag-5.18 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -spacing1 2.0x
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {bad screen distance "2.0x"}
+test textTag-5.19 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -spacing1 lousy
+} -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 "lousy"}
+test textTag-5.20 {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 4.2.3
+} -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 "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,7 +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}
@@ -614,12 +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 {
- catch {.t tag delete x}
- catch {.t tag delete y}
+} -result {x-up up up y-up up}
+
+test textTag-15.2 {TkTextBindProc} -constraints haveCourier12 -setup {
+ .t tag delete x y
+ event generate {} <Motion> -warp 1 -x -1 -y -1; update
+} -body {
.t tag bind x <Enter> {lappend x x-enter}
.t tag bind x <ButtonPress> {lappend x x-down}
.t tag bind x <ButtonRelease> {lappend x x-up}
@@ -639,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}
@@ -667,14 +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
@@ -689,23 +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
@@ -719,11 +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
@@ -736,55 +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 {
- foreach i {a b c d} {
- .t tag remove $i 1.0 end
+ return $x
+} -cleanup {
+ .t tag delete {*}[.t tag names]
+} -result {enter-a enter-b enter-c | leave-c leave-b}
+
+test textTag-16.5 {TkTextPickCurrent procedure} -constraints {
+ haveCourier12
+} -setup {
+ foreach i {big a b c d} {
+ .t tag remove $i 1.0 end
}
+ event generate {} <Motion> -warp 1 -x -1 -y -1; update
+} -body {
+ .t tag configure big -font $bigFont
event gen .t <Motion> -x $x1 -y $y1
.t tag bind a <Enter> {.t tag add big 3.0 3.2}
.t tag add a 3.2
event gen .t <Motion> -x $x2 -y $y2
.t index current
-} {3.2}
-test textTag-16.6 {TkTextPickCurrent procedure} haveCourier12 {
- foreach i {a b c d} {
- .t tag remove $i 1.0 end
+} -cleanup {
+ .t tag delete a big
+} -result {3.2}
+
+test textTag-16.6 {TkTextPickCurrent procedure} -constraints {
+ haveCourier12
+} -setup {
+ foreach i {big a b c d} {
+ .t tag remove $i 1.0 end
}
+ event generate {} <Motion> -warp 1 -x -1 -y -1; update
+} -body {
+ .t tag configure big -font $bigFont
event gen .t <Motion> -x $x1 -y $y1
.t tag bind a <Enter> {.t tag add big 3.0 3.2}
.t tag add a 3.2
event gen .t <Motion> -x $x2 -y $y2
update
.t index current
-} {3.1}
-test textTag-16.7 {TkTextPickCurrent procedure} haveCourier12 {
- foreach i {a b c d} {
- .t tag remove $i 1.0 end
+} -cleanup {
+ .t tag delete a big
+} -result {3.1}
+
+test textTag-16.7 {TkTextPickCurrent procedure} -constraints {
+ haveCourier12
+} -setup {
+ foreach i {big a b c d} {
+ .t tag remove $i 1.0 end
}
+ event generate {} <Motion> -warp 1 -x -1 -y -1; update
+} -body {
+ .t tag configure big -font $bigFont
+ .t tag bind a <Enter> {.t tag add big 3.0 3.2}
+ .t tag add a 3.2
+
event gen .t <Motion> -x $x1 -y $y1
.t tag bind a <Leave> {.t tag add big 3.0 3.2}
.t tag add a 2.1
event gen .t <Motion> -x $x2 -y $y2
+ update
.t index current
-} {3.1}
+} -cleanup {
+ .t tag delete a big
+} -result {3.1}
+
-test textTag-17.1 {insert procedure inserts tags} {
+test textTag-17.1 {insert procedure inserts tags} -setup {
.t delete 1.0 end
+} -body {
# Objectification of the text widget had a problem
# with inserting tags when using 'end'. Check that
# bug has been fixed.
.t insert end abcd {x} \n {} efgh {y} \n {}
.t dump -tag 1.0 end
-} {tagon x 1.0 tagoff x 1.4 tagon y 2.0 tagoff y 2.4}
+} -result {tagon x 1.0 tagoff x 1.4 tagon y 2.0 tagoff y 2.4}
-catch {destroy .t}
-test textTag-18.1 {TkTextPickCurrent tag bindings} {
+test textTag-18.1 {TkTextPickCurrent tag bindings} -setup {
+ destroy .t
+ event generate {} <Motion> -warp 1 -x -1 -y -1; update
+} -body {
text .t -width 30 -height 4 -relief sunken -borderwidth 10 \
-highlightthickness 10 -pady 2
pack .t
@@ -805,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 79dca50..c3483e6 100644
--- a/tests/textWind.test
+++ b/tests/textWind.test
@@ -6,8 +6,9 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
-eval tcltest::configure $argv
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::configure {*}$argv
tcltest::loadTestedCommands
# Create entries in the option database to be sure that geometry options
@@ -17,26 +18,21 @@ option add *Text.borderWidth 2
option add *Text.highlightThickness 2
option add *Text.font {Courier -12}
-set fixedFont {Courier -12}
-# 15 on XP, 13 on Solaris 8
-set fixedHeight [font metrics $fixedFont -linespace]
-# 7 on all platforms
-set fixedWidth [font measure $fixedFont m]
-# 12 on XP
-set fixedAscent [font metrics $fixedFont -ascent]
-set fixedDiff [expr {$fixedHeight - 13}] ;# 2 on XP
-
-catch {destroy .f}
-catch {destroy .t}
-catch {destroy .t2}
+deleteWindows
+# Widget used in tests 1.* - 16.*
text .t -width 30 -height 6 -bd 2 -highlightthickness 2
pack append . .t {top expand fill}
update
.t debug on
-wm geometry . {}
+
+# 15 on XP, 13 on Solaris 8
+set fixedHeight [font metrics {Courier -12} -linespace]
+set fixedDiff [expr {$fixedHeight - 13}] ;# 2 on XP
set color [expr {[winfo depth .t] > 1 ? "green" : "black"}]
-
+
+wm geometry . {}
+
# The statements below reset the main window; it's needed if the window
# manager is mwm to make mwm forget about a previous minimum size setting.
@@ -45,206 +41,323 @@ wm minsize . 1 1
wm positionfrom . user
wm deiconify .
-test textWind-1.1 {basic tests of options} {fonts} {
+# ----------------------------------------------------------------------
+
+test textWind-1.1 {basic tests of options} -constraints fonts -setup {
.t delete 1.0 end
+} -body {
.t insert end "This is the first line"
.t insert end "\nAnd this is a second line, which wraps around"
frame .f -width 3 -height 3 -bg $color
.t window create 2.2 -window .f
update
list [winfo ismapped .f] [winfo geom .f] [.t bbox .f] \
- [.t window configure .f -window]
-} {1 3x3+19+23 {19 23 3 3} {-window {} {} {} .f}}
-test textWind-1.2 {basic tests of options} {fonts} {
+ [.t window configure .f -window]
+} -result {1 3x3+19+23 {19 23 3 3} {-window {} {} {} .f}}
+test textWind-1.2 {basic tests of options} -constraints fonts -setup {
.t delete 1.0 end
+} -body {
.t insert end "This is the first line"
.t insert end "\nAnd this is a second line, which wraps around"
frame .f -width 3 -height 3 -bg $color
.t window create 2.2 -window .f -align top
update
list [winfo ismapped .f] [winfo geom .f] [.t bbox .f] \
- [.t window configure .f -align]
-} {1 3x3+19+18 {19 18 3 3} {-align {} {} center top}}
-test textWind-1.3 {basic tests of options} {
+ [.t window configure .f -align]
+} -result {1 3x3+19+18 {19 18 3 3} {-align {} {} center top}}
+test textWind-1.3 {basic tests of options} -setup {
.t delete 1.0 end
+} -body {
.t insert end "This is the first line"
.t insert end "\nAnd this is a second line, which wraps around"
.t window create 2.2 -create "Test script"
.t window configure 2.2 -create
-} {-create {} {} {} {Test script}}
-test textWind-1.4 {basic tests of options} {fonts} {
+} -result {-create {} {} {} {Test script}}
+test textWind-1.4 {basic tests of options} -constraints fonts -setup {
.t delete 1.0 end
+} -body {
.t insert end "This is the first line"
.t insert end "\nAnd this is a second line, which wraps around"
frame .f -width 10 -height 20 -bg $color
.t window create 2.2 -window .f -padx 5
update
list [winfo geom .f] [.t window configure .f -padx] [.t bbox 2.3]
-} {10x20+24+18 {-padx {} {} 0 5} {39 21 7 13}}
-test textWind-1.5 {basic tests of options} {fonts} {
+} -result {10x20+24+18 {-padx {} {} 0 5} {39 21 7 13}}
+test textWind-1.5 {basic tests of options} -constraints fonts -setup {
.t delete 1.0 end
+} -body {
.t insert end "This is the first line"
.t insert end "\nAnd this is a second line, which wraps around"
frame .f -width 10 -height 20 -bg $color
.t window create 2.2 -window .f -pady 4
update
list [winfo geom .f] [.t window configure .f -pady] [.t bbox 2.31]
-} {10x20+19+22 {-pady {} {} 0 4} {19 46 7 13}}
-test textWind-1.6 {basic tests of options} {fonts} {
+} -result {10x20+19+22 {-pady {} {} 0 4} {19 46 7 13}}
+test textWind-1.6 {basic tests of options} -constraints fonts -setup {
.t delete 1.0 end
+} -body {
.t insert end "This is the first line"
.t insert end "\nAnd this is a second line, which wraps around"
frame .f -width 5 -height 5 -bg $color
.t window create 2.2 -window .f -stretch 1
update
list [winfo geom .f] [.t window configure .f -stretch]
-} {5x13+19+18 {-stretch {} {} 0 1}}
+} -result {5x13+19+18 {-stretch {} {} 0 1}}
+
.t delete 1.0 end
.t insert end "This is the first line"
-frame .f -width 10 -height 6 -bg $color
-.t window create 1.3 -window .f -padx 1 -pady 2
-test textWind-2.1 {TkTextWindowCmd procedure} {
- list [catch {.t window} msg] $msg
-} {1 {wrong # args: should be ".t window option ?arg arg ...?"}}
-test textWind-2.2 {TkTextWindowCmd procedure, "cget" option} {
- list [catch {.t window cget} msg] $msg
-} {1 {wrong # args: should be ".t window cget index option"}}
-test textWind-2.3 {TkTextWindowCmd procedure, "cget" option} {
- list [catch {.t window cget a b c} msg] $msg
-} {1 {wrong # args: should be ".t window cget index option"}}
-test textWind-2.4 {TkTextWindowCmd procedure, "cget" option} {
- list [catch {.t window cget gorp -padx} msg] $msg
-} {1 {bad text index "gorp"}}
-test textWind-2.5 {TkTextWindowCmd procedure, "cget" option} {
- list [catch {.t window cget 1.2 -padx} msg] $msg
-} {1 {no embedded window at index "1.2"}}
-test textWind-2.6 {TkTextWindowCmd procedure, "cget" option} {
- list [catch {.t window cget .f -bogus} msg] $msg
-} {1 {unknown option "-bogus"}}
-test textWind-2.7 {TkTextWindowCmd procedure, "cget" option} {
- list [catch {.t window cget .f -pady} msg] $msg
-} {0 2}
-test textWind-2.8 {TkTextWindowCmd procedure} {
- list [catch {.t window co} msg] $msg
-} {1 {wrong # args: should be ".t window configure index ?option value ...?"}}
-test textWind-2.9 {TkTextWindowCmd procedure} {
- list [catch {.t window configure gorp} msg] $msg
-} {1 {bad text index "gorp"}}
-test textWind-2.10 {TkTextWindowCmd procedure} {
- .t delete 1.0 end
- list [catch {.t window configure 1.0} msg] $msg
-} {1 {no embedded window at index "1.0"}}
-test textWind-2.11 {TkTextWindowCmd procedure} {
+test textWind-2.1 {TkTextWindowCmd procedure} -body {
+ .t window
+} -returnCodes error -result {wrong # args: should be ".t window option ?arg ...?"}
+test textWind-2.2 {TkTextWindowCmd procedure, "cget" option} -body {
+ .t window cget
+} -returnCodes error -result {wrong # args: should be ".t window cget index option"}
+test textWind-2.3 {TkTextWindowCmd procedure, "cget" option} -body {
+ .t window cget a b c
+} -returnCodes error -result {wrong # args: should be ".t window cget index option"}
+test textWind-2.4 {TkTextWindowCmd procedure, "cget" option} -body {
+ .t window cget gorp -padx
+} -returnCodes error -result {bad text index "gorp"}
+test textWind-2.5 {TkTextWindowCmd procedure, "cget" option} -body {
+ .t window cget 1.2 -padx
+} -returnCodes error -result {no embedded window at index "1.2"}
+test textWind-2.6 {TkTextWindowCmd procedure, "cget" option} -setup {
+ destroy .f
+} -body {
+ frame .f -width 10 -height 6 -bg $color
+ .t window create 1.3 -window .f -padx 1 -pady 2
+ .t window cget .f -bogus
+} -cleanup {
+ destroy .f
+} -returnCodes error -result {unknown option "-bogus"}
+test textWind-2.7 {TkTextWindowCmd procedure, "cget" option} -setup {
+ destroy .f
+} -body {
+ frame .f -width 10 -height 6 -bg $color
+ .t window create 1.3 -window .f -padx 1 -pady 2
+ .t window cget .f -pady
+} -cleanup {
+ destroy .f
+} -returnCodes ok -result {2}
+test textWind-2.8 {TkTextWindowCmd procedure} -body {
+ .t window co
+} -returnCodes error -result {wrong # args: should be ".t window configure index ?-option value ...?"}
+test textWind-2.9 {TkTextWindowCmd procedure} -body {
+ .t window configure gorp
+} -returnCodes error -result {bad text index "gorp"}
+test textWind-2.10 {TkTextWindowCmd procedure} -body {
+ .t delete 1.0 end
+ .t window configure 1.0
+} -returnCodes error -result {no embedded window at index "1.0"}
+test textWind-2.11 {TkTextWindowCmd procedure} -setup {
+# I kept this as it "influenced" the test case in previous releases
+ destroy .f
+ frame .f -width 10 -height 6 -bg $color
+ .t window create 1.3 -window .f -padx 1 -pady 2
.t delete 1.0 end
+} -body {
.t insert end "This is the first line"
.t insert end "\nAnd this is a second line, which wraps around"
frame .f -width 10 -height 6 -bg $color
.t window create 2.2 -window .f -align baseline -padx 1 -pady 2 -create foo
update
- list [catch {.t window configure .f} msg] $msg
-} {0 {{-align {} {} center baseline} {-create {} {} {} foo} {-padx {} {} 0 1} {-pady {} {} 0 2} {-stretch {} {} 0 0} {-window {} {} {} .f}}}
-test textWind-2.12 {TkTextWindowCmd procedure} {
+ .t window configure .f
+} -cleanup {
+ destroy .f
+} -result {{-align {} {} center baseline} {-create {} {} {} foo} {-padx {} {} 0 1} {-pady {} {} 0 2} {-stretch {} {} 0 0} {-window {} {} {} .f}}
+test textWind-2.12 {TkTextWindowCmd procedure} -setup {
+# I kept this as it "influenced" the test case in previous releases
+ destroy .f
+ frame .f -width 10 -height 6 -bg $color
+ .t window create 2.2 -window .f -align baseline -padx 1 -pady 2 -create foo
.t delete 1.0 end
+} -body {
.t insert end "This is the first line"
.t insert end "\nAnd this is a second line, which wraps around"
frame .f -width 10 -height 6 -bg $color
.t window create 2.2 -window .f -align baseline -padx 1 -pady 2 -create foo
update
list [.t window configure .f -padx 33] [.t window configure .f -padx]
-} {{} {-padx {} {} 0 33}}
-test textWind-2.13 {TkTextWindowCmd procedure} {
+} -cleanup {
+ destroy .f
+} -result {{} {-padx {} {} 0 33}}
+test textWind-2.13 {TkTextWindowCmd procedure} -setup {
+# I kept this as it "influenced" the test case in previous releases
+ destroy .f
+ frame .f -width 10 -height 6 -bg $color
+ .t window create 2.2 -window .f -align baseline -padx 1 -pady 2 -create foo
.t delete 1.0 end
+} -body {
.t insert end "This is the first line"
.t insert end "\nAnd this is a second line, which wraps around"
frame .f -width 10 -height 6 -bg $color
.t window create 2.2 -window .f -align baseline -padx 1 -pady 2
update
list [.t window configure .f -padx 14 -pady 15] \
- [.t window configure .f -padx] [.t window configure .f -pady]
-} {{} {-padx {} {} 0 14} {-pady {} {} 0 15}}
-test textWind-2.14 {TkTextWindowCmd procedure} {
- list [catch {.t window create} msg] $msg
-} {1 {wrong # args: should be ".t window create index ?option value ...?"}}
-test textWind-2.15 {TkTextWindowCmd procedure} {
- list [catch {.t window create gorp} msg] $msg
-} {1 {bad text index "gorp"}}
-test textWind-2.16 {TkTextWindowCmd procedure, don't insert after end} {
+ [.t window configure .f -padx] [.t window configure .f -pady]
+} -cleanup {
+ destroy .f
+} -result {{} {-padx {} {} 0 14} {-pady {} {} 0 15}}
+test textWind-2.14 {TkTextWindowCmd procedure} -setup {
+ .t delete 1.0 end
+} -body {
+ .t window create
+} -returnCodes error -result {wrong # args: should be ".t window create index ?-option value ...?"}
+test textWind-2.15 {TkTextWindowCmd procedure} -setup {
+ .t delete 1.0 end
+} -body {
+ .t window create gorp
+} -returnCodes error -result {bad text index "gorp"}
+test textWind-2.16 {TkTextWindowCmd procedure, don't insert after end} -setup {
+# I kept this as it "influenced" the test case in previous releases
+ destroy .f
+ frame .f -width 10 -height 6 -bg $color
+ .t window create 2.2 -window .f -align baseline -padx 1 -pady 2
.t delete 1.0 end
+} -body {
.t insert end "Line 1\nLine 2"
frame .f -width 20 -height 10 -bg $color
.t window create end -window .f
.t index .f
-} {2.6}
-test textWind-2.17 {TkTextWindowCmd procedure} {
+} -result {2.6}
+test textWind-2.17 {TkTextWindowCmd procedure} -setup {
.t delete 1.0 end
+} -body {
list [catch {.t window create 1.0} msg] $msg [.t window configure 1.0]
-} {0 {} {{-align {} {} center center} {-create {} {} {} {}} {-padx {} {} 0 0} {-pady {} {} 0 0} {-stretch {} {} 0 0} {-window {} {} {} {}}}}
-test textWind-2.18 {TkTextWindowCmd procedure} {
+} -result {0 {} {{-align {} {} center center} {-create {} {} {} {}} {-padx {} {} 0 0} {-pady {} {} 0 0} {-stretch {} {} 0 0} {-window {} {} {} {}}}}
+test textWind-2.18 {TkTextWindowCmd procedure} -setup {
+# I kept this as it "influenced" the test case in previous releases
+ destroy .f
+ frame .f -width 20 -height 10 -bg $color
+ .t window create end -window .f
+ .t delete 1.0 end
+} -body {
+ frame .f -width 10 -height 6 -bg $color
+ .t window create 1.0 -window .f -gorp stupid
+} -returnCodes error -result {unknown option "-gorp"}
+test textWind-2.19 {TkTextWindowCmd procedure} -setup {
+# I kept this as it "influenced" the test case in previous releases
+ destroy .f
+ frame .f -width 20 -height 10 -bg $color
+ .t window create end -window .f
+ .t delete 1.0 end
+} -body {
+ frame .f -width 10 -height 6 -bg $color
+ catch {.t window create 1.0 -window .f -gorp stupid}
+ list [winfo exists .f] [.t index 1.end] [catch {.t index .f}]
+} -result {0 1.0 1}
+test textWind-2.20 {TkTextWindowCmd procedure} -setup {
.t delete 1.0 end
+ destroy .f
+} -body {
frame .f -width 10 -height 6 -bg $color
- list [catch {.t window create 1.0 -window .f -gorp stupid} msg] $msg \
- [winfo exists .f] [.t index 1.end] [catch {.t index .f}]
-} {1 {unknown option "-gorp"} 0 1.0 1}
-test textWind-2.19 {TkTextWindowCmd procedure} {
+ .t window create 1.0 -gorp -window .f stupid
+} -returnCodes error -result {unknown option "-gorp"}
+test textWind-2.21 {TkTextWindowCmd procedure} -setup {
.t delete 1.0 end
- catch {destroy .f}
+ destroy .f
+} -body {
frame .f -width 10 -height 6 -bg $color
- list [catch {.t window create 1.0 -gorp -window .f stupid} msg] $msg \
- [winfo exists .f] [.t index 1.end] [catch {.t index .f}]
-} {1 {unknown option "-gorp"} 1 1.0 1}
-test textWind-2.20 {TkTextWindowCmd procedure} {
- list [catch {.t window c} msg] $msg
-} {1 {ambiguous window option "c": must be cget, configure, create, or names}}
+ catch {.t window create 1.0 -gorp -window .f stupid}
+ list [winfo exists .f] [.t index 1.end] [catch {.t index .f}]
+} -result {1 1.0 1}
+test textWind-2.22 {TkTextWindowCmd procedure} -setup {
+ .t delete 1.0 end
+} -body {
+ .t window c
+} -returnCodes error -result {ambiguous window option "c": must be cget, configure, create, or names}
destroy .f
-test textWind-2.21 {TkTextWindowCmd procedure, "names" option} {
- list [catch {.t window names foo} msg] $msg
-} {1 {wrong # args: should be ".t window names"}}
-test textWind-2.22 {TkTextWindowCmd procedure, "names" option} {
+test textWind-2.23 {TkTextWindowCmd procedure, "names" option} -setup {
+ .t delete 1.0 end
+} -body {
+ .t window names foo
+} -returnCodes error -result {wrong # args: should be ".t window names"}
+test textWind-2.24 {TkTextWindowCmd procedure, "names" option} -setup {
.t delete 1.0 end
+} -body {
.t window names
-} {}
-test textWind-2.23 {TkTextWindowCmd procedure, "names" option} {
+} -result {}
+test textWind-2.25 {TkTextWindowCmd procedure, "names" option} -setup {
.t delete 1.0 end
+ destroy .f .f2 .t.f .t.f2
+} -body {
foreach i {.f .f2 .t.f .t.f2} {
- frame $i -width 20 -height 20
- .t window create end -window $i
+ frame $i -width 20 -height 20
+ .t window create end -window $i
}
- set result [.t window names]
+ lsort [.t window names]
+} -cleanup {
destroy .f .f2 .t.f .t.f2
- lsort $result
-} {.f .f2 .t.f .t.f2}
+} -result {.f .f2 .t.f .t.f2}
-test textWind-3.1 {EmbWinConfigure procedure} {
- .t delete 1.0 end
+
+test textWind-3.1 {EmbWinConfigure procedure} -setup {
+ destroy .f
+} -body {
frame .f -width 10 -height 6 -bg $color
.t window create 1.0 -window .f
- list [catch {.t window configure 1.0 -foo bar} msg] $msg
-} {1 {unknown option "-foo"}}
-test textWind-3.2 {EmbWinConfigure procedure} {fonts} {
- .t delete 1.0 end
+ .t window configure 1.0 -foo bar
+} -cleanup {
+ destroy .f
+} -returnCodes error -result {unknown option "-foo"}
+test textWind-3.2 {EmbWinConfigure procedure} -constraints fonts -setup {
+ destroy .f
+} -body {
.t insert 1.0 "Some sample text"
frame .f -width 10 -height 20 -bg $color
.t window create 1.3 -window .f
update
.t window configure 1.3 -window {}
update
- list [catch {.t index .f} msg] $msg [winfo ismapped .f] [.t bbox 1.4]
-} {1 {bad text index ".f"} 0 {26 5 7 13}}
-catch {destroy .f}
-test textWind-3.3 {EmbWinConfigure procedure} {fonts} {
- .t delete 1.0 end
+ .t index .f
+} -cleanup {
+ destroy .f
+} -returnCodes error -result {bad text index ".f"}
+test textWind-3.3 {EmbWinConfigure procedure} -constraints fonts -setup {
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f -width 10 -height 20 -bg $color
+ .t window create 1.3 -window .f
+ update
+ .t window configure 1.3 -window {}
+ update
+ catch {.t index .f}
+ list [winfo ismapped .f] [.t bbox 1.4]
+} -cleanup {
+ destroy .f
+} -result {0 {26 5 7 13}}
+test textWind-3.4 {EmbWinConfigure procedure} -constraints fonts -setup {
+ destroy .t.f
+} -body {
.t insert 1.0 "Some sample text"
frame .t.f -width 10 -height 20 -bg $color
.t window create 1.3 -window .t.f
update
.t window configure 1.3 -window {}
update
- list [catch {.t index .t.f} msg] $msg [winfo ismapped .t.f] [.t bbox 1.4]
-} {1 {bad text index ".t.f"} 0 {26 5 7 13}}
-catch {destroy .t.f}
-test textWind-3.4 {EmbWinConfigure procedure} {fonts} {
- .t delete 1.0 end
+ .t index .t.f
+} -cleanup {
+ destroy .t.f
+} -returnCodes error -result {bad text index ".t.f"}
+test textWind-3.5 {EmbWinConfigure procedure} -constraints fonts -setup {
+ destroy .t.f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .t.f -width 10 -height 20 -bg $color
+ .t window create 1.3 -window .t.f
+ update
+ .t window configure 1.3 -window {}
+ update
+ catch {.t index .t.f}
+ list [winfo ismapped .t.f] [.t bbox 1.4]
+} -cleanup {
+ destroy .t.f
+} -result {0 {26 5 7 13}}
+test textWind-3.6 {EmbWinConfigure procedure} -constraints fonts -setup {
+ destroy .f
+} -body {
.t insert 1.0 "Some sample text"
frame .f -width 10 -height 20 -bg $color
.t window create 1.3
@@ -252,89 +365,143 @@ test textWind-3.4 {EmbWinConfigure procedure} {fonts} {
.t window configure 1.3 -window .f
update
list [catch {.t index .f} msg] $msg [winfo ismapped .f] [.t bbox 1.4]
-} {0 1.3 1 {36 8 7 13}}
-test textWind-3.5 {EmbWinConfigure procedure} {
- .t delete 1.0 end
+} -cleanup {
+ destroy .f
+} -result {0 1.3 1 {36 8 7 13}}
+test textWind-3.7 {EmbWinConfigure procedure} -setup {
+ destroy .f
+} -body {
.t insert 1.0 "Some sample text"
frame .f
frame .f.f -width 15 -height 20 -bg $color
pack .f.f
- list [catch {.t window create 1.3 -window .f.f} msg] $msg
-} {1 {can't embed .f.f in .t}}
-catch {destroy .f}
-test textWind-3.6 {EmbWinConfigure procedure} {
- .t delete 1.0 end
+ .t window create 1.3 -window .f.f
+} -cleanup {
+ destroy .f
+} -returnCodes error -result {can't embed .f.f in .t}
+test textWind-3.8 {EmbWinConfigure procedure} -setup {
+ destroy .t2
+} -body {
.t insert 1.0 "Some sample text"
toplevel .t2 -width 20 -height 10 -bg $color
.t window create 1.3
- list [catch {.t window configure 1.3 -window .t2} msg] $msg \
- [.t window configure 1.3 -window]
-} {1 {can't embed .t2 in .t} {-window {} {} {} {}}}
-catch {destroy .t2}
-test textWind-3.7 {EmbWinConfigure procedure} {
- .t delete 1.0 end
+ .t window configure 1.3 -window .t2
+} -cleanup {
+ destroy .t2
+} -returnCodes error -result {can't embed .t2 in .t}
+test textWind-3.9 {EmbWinConfigure procedure} -setup {
+ destroy .t2
+} -body {
+ .t insert 1.0 "Some sample text"
+ toplevel .t2 -width 20 -height 10 -bg $color
+ .t window create 1.3
+ catch {.t window configure 1.3 -window .t2}
+ .t window configure 1.3 -window
+} -cleanup {
+ destroy .t2
+} -result {-window {} {} {} {}}
+test textWind-3.10 {EmbWinConfigure procedure} -setup {
+ .t delete 1.0 end
+} -body {
.t insert 1.0 "Some sample text"
.t window create 1.3
- list [catch {.t window configure 1.3 -window .t} msg] $msg
-} {1 {can't embed .t in .t}}
-test textWind-3.8 {EmbWinConfigure procedure} {
+ .t window configure 1.3 -window .t
+} -returnCodes error -result {can't embed .t in .t}
+test textWind-3.11 {EmbWinConfigure procedure} -setup {
+ .t delete 1.0 end
+} -body {
# This test checks for various errors when the text claims
# a window away from itself.
- .t delete 1.0 end
.t insert 1.0 "Some sample text"
button .t.b -text "Hello!"
.t window create 1.4 -window .t.b
.t window create 1.6 -window .t.b
update
.t index .t.b
-} {1.6}
+} -result {1.6}
+
.t delete 1.0 end
frame .f -width 10 -height 20 -bg $color
.t window create 1.0 -window .f
-test textWind-4.1 {AlignParseProc and AlignPrintProc procedures} {
+test textWind-4.1 {AlignParseProc and AlignPrintProc procedures} -body {
.t window configure 1.0 -align baseline
.t window configure 1.0 -align
-} {-align {} {} center baseline}
-test textWind-4.2 {AlignParseProc and AlignPrintProc procedures} {
+} -result {-align {} {} center baseline}
+test textWind-4.2 {AlignParseProc and AlignPrintProc procedures} -body {
.t window configure 1.0 -align bottom
.t window configure 1.0 -align
-} {-align {} {} center bottom}
-test textWind-4.3 {AlignParseProc and AlignPrintProc procedures} {
+} -result {-align {} {} center bottom}
+test textWind-4.3 {AlignParseProc and AlignPrintProc procedures} -body {
.t window configure 1.0 -align center
.t window configure 1.0 -align
-} {-align {} {} center center}
-test textWind-4.4 {AlignParseProc and AlignPrintProc procedures} {
+} -result {-align {} {} center center}
+test textWind-4.4 {AlignParseProc and AlignPrintProc procedures} -body {
.t window configure 1.0 -align top
.t window configure 1.0 -align
-} {-align {} {} center top}
-test textWind-4.5 {AlignParseProc and AlignPrintProc procedures} {
+} -result {-align {} {} center top}
+test textWind-4.5 {AlignParseProc and AlignPrintProc procedures} -body {
+ .t window configure 1.0 -align top
+ .t window configure 1.0 -align gorp
+} -returnCodes error -result {bad align "gorp": must be baseline, bottom, center, or top}
+test textWind-4.6 {AlignParseProc and AlignPrintProc procedures} -body {
.t window configure 1.0 -align top
- list [catch {.t window configure 1.0 -align gorp} msg] $msg \
- [.t window configure 1.0 -align]
-} {1 {bad align "gorp": must be baseline, bottom, center, or top} {-align {} {} center top}}
+ catch {.t window configure 1.0 -align gorp}
+ .t window configure 1.0 -align
+} -result {-align {} {} center top}
+
-test textWind-5.1 {EmbWinStructureProc procedure} {fonts} {
+test textWind-5.1 {EmbWinStructureProc procedure} -constraints fonts -setup {
.t delete 1.0 end
+ destroy .f
+} -body {
.t insert 1.0 "Some sample text"
frame .f -width 10 -height 20 -bg $color
.t window create 1.2 -window .f
update
destroy .f
- list [catch {.t index .f} msg] $msg [.t bbox 1.2] [.t bbox 1.3]
-} {1 {bad text index ".f"} {19 11 0 0} {19 5 7 13}}
-test textWind-5.2 {EmbWinStructureProc procedure} {fonts} {
+ .t index .f
+} -returnCodes error -result {bad text index ".f"}
+test textWind-5.2 {EmbWinStructureProc procedure} -constraints fonts -setup {
.t delete 1.0 end
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f -width 10 -height 20 -bg $color
+ .t window create 1.2 -window .f
+ update
+ destroy .f
+ catch {.t index .f}
+ list [.t bbox 1.2] [.t bbox 1.3]
+} -result {{19 11 0 0} {19 5 7 13}}
+test textWind-5.3 {EmbWinStructureProc procedure} -constraints fonts -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
.t insert 1.0 "Some sample text"
frame .f -width 10 -height 20 -bg $color
.t window create 1.2 -align bottom
.t window configure 1.2 -window .f
update
destroy .f
- list [catch {.t index .f} msg] $msg [.t bbox 1.2] [.t bbox 1.3]
-} {1 {bad text index ".f"} {19 18 0 0} {19 5 7 13}}
-test textWind-5.3 {EmbWinStructureProc procedure} {fonts} {
+ .t index .f
+} -returnCodes error -result {bad text index ".f"}
+test textWind-5.4 {EmbWinStructureProc procedure} -constraints fonts -setup {
+ .t delete 1.0 end
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f -width 10 -height 20 -bg $color
+ .t window create 1.2 -align bottom
+ .t window configure 1.2 -window .f
+ update
+ destroy .f
+ catch {.t index .f}
+ list [.t bbox 1.2] [.t bbox 1.3]
+} -result {{19 18 0 0} {19 5 7 13}}
+test textWind-5.5 {EmbWinStructureProc procedure} -constraints fonts -setup {
.t delete 1.0 end
+ destroy .f
+} -body {
.t insert 1.0 "Some sample text"
.t window create 1.2 -create {frame .f -width 10 -height 20 -bg $color}
update
@@ -342,21 +509,31 @@ test textWind-5.3 {EmbWinStructureProc procedure} {fonts} {
destroy .f
update
list [catch {.t index .f} msg] $msg [.t bbox 1.2] [.t bbox 1.3]
-} {0 1.2 {19 6 20 10} {39 5 7 13}}
+} -result {0 1.2 {19 6 20 10} {39 5 7 13}}
+
-test textWind-6.1 {EmbWinRequestProc procedure} {fonts} {
+test textWind-6.1 {EmbWinRequestProc procedure} -constraints fonts -setup {
.t delete 1.0 end
+ destroy .f
+ set result {}
+} -body {
.t insert 1.0 "Some sample text"
frame .f -width 10 -height 20 -bg $color
.t window create 1.2 -window .f
- set result {}
lappend result [.t bbox 1.2] [.t bbox 1.3]
.f configure -width 25 -height 30
lappend result [.t bbox 1.2] [.t bbox 1.3]
-} {{19 5 10 20} {29 8 7 13} {19 5 25 30} {44 13 7 13}}
+} -cleanup {
+ destroy .f
+} -result {{19 5 10 20} {29 8 7 13} {19 5 25 30} {44 13 7 13}}
-test textWind-7.1 {EmbWinLostSlaveProc procedure} {textfonts} {
+
+test textWind-7.1 {EmbWinLostSlaveProc procedure} -constraints {
+ textfonts
+} -setup {
.t delete 1.0 end
+ destroy .f
+} -body {
.t insert 1.0 "Some sample text"
frame .f -width 10 -height 20 -bg $color
.t window create 1.2 -window .f
@@ -364,9 +541,15 @@ test textWind-7.1 {EmbWinLostSlaveProc procedure} {textfonts} {
place .f -in .t -x 100 -y 50
update
list [winfo geom .f] [.t bbox 1.2]
-} [list 10x20+105+55 [list 19 [expr {11+$fixedDiff/2}] 0 0]]
-test textWind-7.2 {EmbWinLostSlaveProc procedure} {textfonts} {
+} -cleanup {
+ destroy .f
+} -result [list 10x20+105+55 [list 19 [expr {11+$fixedDiff/2}] 0 0]]
+test textWind-7.2 {EmbWinLostSlaveProc procedure} -constraints {
+ textfonts
+} -setup {
.t delete 1.0 end
+ destroy .t.f
+} -body {
.t insert 1.0 "Some sample text"
frame .t.f -width 10 -height 20 -bg $color
.t window create 1.2 -window .t.f
@@ -374,76 +557,124 @@ test textWind-7.2 {EmbWinLostSlaveProc procedure} {textfonts} {
place .t.f -x 100 -y 50
update
list [winfo geom .t.f] [.t bbox 1.2]
-} [list 10x20+105+55 [list 19 [expr {11+$fixedDiff/2}] 0 0]]
-catch {destroy .f}
-catch {destroy .t.f}
+} -cleanup {
+ destroy .t.f
+} -result [list 10x20+105+55 [list 19 [expr {11+$fixedDiff/2}] 0 0]]
-test textWind-8.1 {EmbWinDeleteProc procedure} {fonts} {
+
+test textWind-8.1 {EmbWinDeleteProc procedure} -constraints fonts -setup {
.t delete 1.0 end
+ destroy .f
+} -body {
.t insert 1.0 "Some sample text"
frame .f -width 10 -height 20 -bg $color
.t window create 1.2 -window .f
bind .f <Destroy> {set x destroyed}
set x XXX
.t delete 1.2
- list $x [.t bbox 1.2] [.t bbox 1.3] [catch {.t index .f} msg] $msg \
- [winfo exists .f]
-} {destroyed {19 5 7 13} {26 5 7 13} 1 {bad text index ".f"} 0}
+ list $x [.t bbox 1.2] [.t bbox 1.3] [winfo exists .f]
+} -result {destroyed {19 5 7 13} {26 5 7 13} 0}
+test textWind-8.2 {EmbWinDeleteProc procedure} -constraints fonts -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t insert 1.0 "Some sample text"
+ frame .f -width 10 -height 20 -bg $color
+ .t window create 1.2 -window .f
+ bind .f <Destroy> {set x destroyed}
+ set x XXX
+ .t delete 1.2
+ .t index .f
+} -returnCodes error -result {bad text index ".f"}
-test textWind-9.1 {EmbWinCleanupProc procedure} {
+
+test textWind-9.1 {EmbWinCleanupProc procedure} -setup {
.t delete 1.0 end
+ destroy .f
+} -body {
.t insert 1.0 "Some sample text\nA second line."
frame .f -width 10 -height 20 -bg $color
.t window create 2.3 -window .f
.t delete 1.5 2.1
.t index .f
-} 1.7
+} -cleanup {
+ destroy .f
+} -result {1.7}
-proc bgerror args {
- global msg
- set msg $args
-}
-test textWind-10.1 {EmbWinLayoutProc procedure} {
+test textWind-10.1 {EmbWinLayoutProc procedure} -setup {
.t delete 1.0 end
- .t insert 1.0 "Some sample text"
destroy .f
+} -body {
+ .t insert 1.0 "Some sample text"
.t window create 1.5 -create {
- frame .f -width 10 -height 20 -bg $color
+ frame .f -width 10 -height 20 -bg $color
}
update
list [winfo exists .f] [winfo width .f] [winfo height .f] [.t index .f]
-} {1 10 20 1.5}
-test textWind-10.2 {EmbWinLayoutProc procedure, error in creating window} {fonts} {
- .t delete 1.0 end
+} -cleanup {
+ destroy .f
+} -result {1 10 20 1.5}
+test textWind-10.2 {EmbWinLayoutProc procedure, error in creating window} -constraints {
+ fonts
+} -setup {
+ .t delete 1.0 end
+ proc bgerror args {
+ global msg
+ set msg $args
+ }
+} -body {
.t insert 1.0 "Some sample text"
- .t window create 1.5 -create {
- error "couldn't create window"
+ .t window create 1.5 -create {
+ error "couldn't create window"
}
set msg xyzzy
update
list $msg [.t bbox 1.5]
-} {{{couldn't create window}} {40 11 0 0}}
-test textWind-10.3 {EmbWinLayoutProc procedure, error in creating window} {fonts} {
- .t delete 1.0 end
+} -cleanup {
+ rename bgerror {}
+} -result {{{couldn't create window}} {40 11 0 0}}
+test textWind-10.3 {EmbWinLayoutProc procedure, error in creating window} -constraints {
+ fonts
+} -setup {
+ .t delete 1.0 end
+ proc bgerror args {
+ global msg
+ set msg $args
+ }
+} -body {
.t insert 1.0 "Some sample text"
.t window create 1.5 -create {
- concat gorp
+ concat gorp
}
set msg xyzzy
update
list $msg [.t bbox 1.5]
-} {{{bad window path name "gorp"}} {40 11 0 0}}
-proc bgerror args {
- global msg
- if {[lsearch -exact $msg $args] == -1} {
- lappend msg $args
+} -cleanup {
+ rename bgerror {}
+} -result {{{bad window path name "gorp"}} {40 11 0 0}}
+ .t delete 1.0 end
+ destroy .t.f
+ proc bgerror args {
+ global msg
+ if {[lsearch -exact $msg $args] == -1} {
+ lappend msg $args
+ }
}
-}
-test textWind-10.4 {EmbWinLayoutProc procedure, error in creating window} {textfonts} {
- .t delete 1.0 end
+
+test textWind-10.4 {EmbWinLayoutProc procedure, error in creating window} -constraints {
+ textfonts
+} -setup {
+ .t delete 1.0 end
+ destroy .t.f
+ proc bgerror args {
+ global msg
+ if {[lsearch -exact $msg $args] == -1} {
+ lappend msg $args
+ }
+ }
+} -body {
.t insert 1.0 "Some sample text"
- catch {destroy .t.f}
set msg {}
after idle {
.t window create 1.5 -create {
@@ -453,68 +684,116 @@ test textWind-10.4 {EmbWinLayoutProc procedure, error in creating window} {textf
}
set count 0
while {([llength $msg] < 2) && ($count < 100)} {
- update ; incr count; .t bbox 1.5 ; after 10
+ update
+ incr count
+ .t bbox 1.5
+ after 10
}
lappend msg [.t bbox 1.5] [winfo exists .t.f.f]
-} [list {{can't embed .t.f.f relative to .t}} {{window name "f" already exists in parent}} [list 40 [expr {11+$fixedDiff/2}] 0 0] 1]
-test textWind-10.4.1 {EmbWinLayoutProc procedure, error in creating window} {textfonts} {
- .t delete 1.0 end
+} -cleanup {
+ destroy .t.f
+ rename bgerror {}
+} -result [list {{can't embed .t.f.f relative to .t}} {{window name "f" already exists in parent}} [list 40 [expr {11+$fixedDiff/2}] 0 0] 1]
+test textWind-10.5 {EmbWinLayoutProc procedure, error in creating window} -constraints {
+ textfonts
+} -setup {
+ .t delete 1.0 end
+ destroy .t.f
+ proc bgerror args {
+ global msg
+ if {[lsearch -exact $msg $args] == -1} {
+ lappend msg $args
+ }
+ }
+} -body {
.t insert 1.0 "Some sample text"
- catch {destroy .t.f}
.t window create 1.5 -create {
- frame .t.f
- frame .t.f.f -width 10 -height 20 -bg $color
+ frame .t.f
+ frame .t.f.f -width 10 -height 20 -bg $color
}
set msg {}
update idletasks
lappend msg [winfo exists .t.f.f]
-} [list {{can't embed .t.f.f relative to .t}} 1]
+} -cleanup {
+ destroy .t.f
+ rename bgerror {}
+} -result {{{can't embed .t.f.f relative to .t}} 1}
catch {destroy .t.f}
-test textWind-10.5 {EmbWinLayoutProc procedure, error in creating window} {textfonts} {
- .t delete 1.0 end
+test textWind-10.6 {EmbWinLayoutProc procedure, error in creating window} -constraints {
+ textfonts
+} -setup {
+ .t delete 1.0 end
+ proc bgerror args {
+ global msg
+ if {[lsearch -exact $msg $args] == -1} {
+ lappend msg $args
+ }
+ }
+} -body {
.t insert 1.0 "Some sample text"
.t window create 1.5 -create {
- concat .t
+ concat .t
}
set msg {}
update
lappend msg [.t bbox 1.5]
-} [list {{can't embed .t relative to .t}} [list 40 [expr {11+$fixedDiff/2}] 0 0]]
-test textWind-10.6 {EmbWinLayoutProc procedure, error in creating window} {textfonts} {
- .t delete 1.0 end
+} -cleanup {
+ rename bgerror {}
+} -result [list {{can't embed .t relative to .t}} [list 40 [expr {11+$fixedDiff/2}] 0 0]]
+test textWind-10.7 {EmbWinLayoutProc procedure, error in creating window} -constraints {
+ textfonts
+} -setup {
+ .t delete 1.0 end
+ destroy .t2
+ proc bgerror args {
+ global msg
+ if {[lsearch -exact $msg $args] == -1} {
+ lappend msg $args
+ }
+ }
+} -body {
.t insert 1.0 "Some sample text"
- catch {destroy .t2}
.t window create 1.5 -create {
- toplevel .t2 -width 100 -height 150
- wm geom .t2 +0+0
- concat .t2
+ toplevel .t2 -width 100 -height 150
+ wm geom .t2 +0+0
+ concat .t2
}
set msg {}
update
lappend msg [.t bbox 1.5]
-} [list {{can't embed .t2 relative to .t}} {{window name "t2" already exists in parent}} [list 40 [expr {11+$fixedDiff/2}] 0 0]]
-test textWind-10.6.1 {EmbWinLayoutProc procedure, error in creating window} {
- .t delete 1.0 end
+} -cleanup {
+ rename bgerror {}
+} -result [list {{can't embed .t2 relative to .t}} {{window name "t2" already exists in parent}} [list 40 [expr {11+$fixedDiff/2}] 0 0]]
+test textWind-10.8 {EmbWinLayoutProc procedure, error in creating window} -setup {
+ .t delete 1.0 end
+ destroy .t2
+ proc bgerror args {
+ global msg
+ if {[lsearch -exact $msg $args] == -1} {
+ lappend msg $args
+ }
+ }
+} -body {
.t insert 1.0 "Some sample text"
- catch {destroy .t2}
.t window create 1.5 -create {
- toplevel .t2 -width 100 -height 150
- wm geom .t2 +0+0
- concat .t2
+ toplevel .t2 -width 100 -height 150
+ wm geom .t2 +0+0
+ concat .t2
}
set msg {}
update
set i 0
while {[llength $msg] == 1 && [incr i] < 200} { update }
- set msg
-} {{{can't embed .t2 relative to .t}} {{window name "t2" already exists in parent}}}
+ return $msg
+} -cleanup {
+ destroy .t2
+ rename bgerror {}
+} -result {{{can't embed .t2 relative to .t}} {{window name "t2" already exists in parent}}}
-proc bgerror args {
- global msg
- set msg $args
-}
-test textWind-10.7 {EmbWinLayoutProc procedure, steal window from self} {
+test textWind-10.9 {EmbWinLayoutProc procedure, steal window from self} -setup {
.t delete 1.0 end
+ destroy .t.b
+} -body {
.t insert 1.0 ABCDEFGHIJKLMNOP
button .t.b -text "Hello!"
.t window create 1.5 -window .t.b
@@ -522,64 +801,104 @@ test textWind-10.7 {EmbWinLayoutProc procedure, steal window from self} {
.t window create 1.3 -create {concat .t.b}
update
.t index .t.b
-} {1.3}
-catch {destroy .t2}
-test textWind-10.8 {EmbWinLayoutProc procedure, doesn't fit on line} {fonts} {
- .t configure -wrap char
+} -cleanup {
+ destroy .t.b
+} -result {1.3}
+test textWind-10.10 {EmbWinLayoutProc procedure, doesn't fit on line} -constraints {
+ fonts
+} -setup {
.t delete 1.0 end
+ destroy .f
+} -body {
+ .t configure -wrap char
.t insert 1.0 "Some sample text"
frame .f -width 125 -height 20 -bg $color -bd 2 -relief raised
.t window create 1.12 -window .f
list [.t bbox .f] [.t bbox 1.13]
-} {{89 5 126 20} {5 25 7 13}}
-test textWind-10.9 {EmbWinLayoutProc procedure, doesn't fit on line} {fonts} {
- .t configure -wrap char
+} -cleanup {
+ destroy .f
+} -result {{89 5 126 20} {5 25 7 13}}
+test textWind-10.11 {EmbWinLayoutProc procedure, doesn't fit on line} -constraints {
+ fonts
+} -setup {
.t delete 1.0 end
+ destroy .f
+} -body {
+ .t configure -wrap char
.t insert 1.0 "Some sample text"
frame .f -width 126 -height 20 -bg $color -bd 2 -relief raised
.t window create 1.12 -window .f
update
list [.t bbox .f] [.t bbox 1.13]
-} {{89 5 126 20} {5 25 7 13}}
-test textWind-10.10 {EmbWinLayoutProc procedure, doesn't fit on line} {fonts} {
- .t configure -wrap char
+} -cleanup {
+ destroy .f
+} -result {{89 5 126 20} {5 25 7 13}}
+test textWind-10.12 {EmbWinLayoutProc procedure, doesn't fit on line} -constraints {
+ fonts
+} -setup {
.t delete 1.0 end
+ destroy .f
+} -body {
+ .t configure -wrap char
.t insert 1.0 "Some sample text"
frame .f -width 127 -height 20 -bg $color -bd 2 -relief raised
.t window create 1.12 -window .f
update
list [.t bbox .f] [.t bbox 1.13]
-} {{5 18 127 20} {132 21 7 13}}
-test textWind-10.11 {EmbWinLayoutProc procedure, doesn't fit on line} {
- .t configure -wrap none
+} -cleanup {
+ destroy .f
+} -result {{5 18 127 20} {132 21 7 13}}
+test textWind-10.13 {EmbWinLayoutProc procedure, doesn't fit on line} -setup {
.t delete 1.0 end
+ destroy .f
+} -body {
+ .t configure -wrap none
.t insert 1.0 "Some sample text"
frame .f -width 130 -height 20 -bg $color -bd 2 -relief raised
.t window create 1.12 -window .f
update
list [.t bbox .f] [.t bbox 1.13]
-} {{89 5 126 20} {}}
-test textWind-10.12 {EmbWinLayoutProc procedure, doesn't fit on line} {fonts} {
- .t configure -wrap none
+} -cleanup {
+ destroy .f
+} -result {{89 5 126 20} {}}
+test textWind-10.14 {EmbWinLayoutProc procedure, doesn't fit on line} -constraints {
+ fonts
+} -setup {
.t delete 1.0 end
+ destroy .f
+} -body {
+ .t configure -wrap none
.t insert 1.0 "Some sample text"
frame .f -width 130 -height 220 -bg $color -bd 2 -relief raised
.t window create 1.12 -window .f
update
list [.t bbox .f] [.t bbox 1.13]
-} {{89 5 126 78} {}}
-test textWind-10.13 {EmbWinLayoutProc procedure, doesn't fit on line} {fonts} {
- .t configure -wrap char
+} -cleanup {
+ destroy .f
+} -result {{89 5 126 78} {}}
+test textWind-10.15 {EmbWinLayoutProc procedure, doesn't fit on line} -constraints {
+ fonts
+} -setup {
.t delete 1.0 end
+ destroy .f
+} -body {
+ .t configure -wrap char
.t insert 1.0 "Some sample text"
frame .f -width 250 -height 220 -bg $color -bd 2 -relief raised
.t window create 1.12 -window .f
update
list [.t bbox .f] [.t bbox 1.13]
-} {{5 18 210 65} {}}
+} -cleanup {
+ destroy .f
+} -result {{5 18 210 65} {}}
+
-test textWind-11.1 {EmbWinDisplayProc procedure, geometry transforms} {
+test textWind-11.1 {EmbWinDisplayProc procedure, geometry transforms} -setup {
.t delete 1.0 end
+ destroy .f
+ place forget .t
+ pack .t
+} -body {
.t insert 1.0 "Some sample text"
pack forget .t
place .t -x 30 -y 50
@@ -587,11 +906,16 @@ test textWind-11.1 {EmbWinDisplayProc procedure, geometry transforms} {
.t window create 1.12 -window .f
update
winfo geom .f
-} {30x20+119+55}
-place forget .t
-pack .t
-test textWind-11.2 {EmbWinDisplayProc procedure, geometry transforms} {
- .t delete 1.0 end
+} -cleanup {
+ destroy .f
+ place forget .t
+} -result {30x20+119+55}
+test textWind-11.2 {EmbWinDisplayProc procedure, geometry transforms} -setup {
+ .t delete 1.0 end
+ destroy .t.f
+ place forget .t
+ pack .t
+} -body {
.t insert 1.0 "Some sample text"
pack forget .t
place .t -x 30 -y 50
@@ -599,11 +923,17 @@ test textWind-11.2 {EmbWinDisplayProc procedure, geometry transforms} {
.t window create 1.12 -window .t.f
update
winfo geom .t.f
-} {30x20+89+5}
-place forget .t
-pack .t
-test textWind-11.3 {EmbWinDisplayProc procedure, configuration optimization} {
+} -cleanup {
+ destroy .t.f
+ place forget .t
+ pack .t
+} -result {30x20+89+5}
+test textWind-11.3 {EmbWinDisplayProc procedure, configuration optimization} -setup {
.t delete 1.0 end
+ destroy .f
+ place forget .t
+ pack .t
+} -body {
.t insert 1.0 "Some sample text"
frame .f -width 30 -height 20 -bg $color
.t window create 1.12 -window .f
@@ -613,10 +943,18 @@ test textWind-11.3 {EmbWinDisplayProc procedure, configuration optimization} {
.t delete 1.0
.t insert 1.0 "X"
update
- set x
-} {no configures}
-test textWind-11.4 {EmbWinDisplayProc procedure, horizontal scrolling} {fonts} {
- .t delete 1.0 end
+ return $x
+} -cleanup {
+ destroy .f
+ place forget .t
+ pack .t
+} -result {no configures}
+test textWind-11.4 {EmbWinDisplayProc procedure, horizontal scrolling} -constraints {
+ fonts
+} -setup {
+ .t delete 1.0 end
+ destroy .f .f2
+} -body {
.t insert 1.0 "xyzzy\nFirst window here: "
.t configure -wrap none
frame .f -width 30 -height 20 -bg $color
@@ -629,9 +967,15 @@ test textWind-11.4 {EmbWinDisplayProc procedure, horizontal scrolling} {fonts} {
.t xview scroll 5 units
update
list [winfo ismapped .f] [winfo geom .f] [.t bbox .f] [winfo ismapped .f2]
-} {1 30x20+103+18 {103 18 30 20} 0}
-test textWind-11.5 {EmbWinDisplayProc procedure, horizontal scrolling} {fonts} {
- .t delete 1.0 end
+} -cleanup {
+ destroy .f .f2
+} -result {1 30x20+103+18 {103 18 30 20} 0}
+test textWind-11.5 {EmbWinDisplayProc procedure, horizontal scrolling} -constraints {
+ fonts
+} -setup {
+ .t delete 1.0 end
+ destroy .f .f2
+} -body {
.t insert 1.0 "xyzzy\nFirst window here: "
.t configure -wrap none
frame .f -width 30 -height 20 -bg $color
@@ -645,11 +989,16 @@ test textWind-11.5 {EmbWinDisplayProc procedure, horizontal scrolling} {fonts} {
.t xview scroll 25 units
update
list [winfo ismapped .f] [winfo ismapped .f2] [winfo geom .f2] [.t bbox .f2]
-} {0 1 40x10+119+23 {119 23 40 10}}
+} -cleanup {
+ destroy .f .f2
+} -result {0 1 40x10+119+23 {119 23 40 10}}
.t configure -wrap char
-test textWind-12.1 {EmbWinUndisplayProc procedure, mapping/unmapping} {
+
+test textWind-12.1 {EmbWinUndisplayProc procedure, mapping/unmapping} -setup {
.t delete 1.0 end
+ destroy .f
+} -body {
.t insert 1.0 "Some sample text"
frame .f -width 30 -height 20 -bg $color
.t window create 1.2 -window .f
@@ -669,74 +1018,114 @@ test textWind-12.1 {EmbWinUndisplayProc procedure, mapping/unmapping} {
.t configure -wrap none
.t insert 1.0 "Enough text to make the line run off-screen"
update
- set x
-} {created mapped modified replaced unmapped mapped off-screen unmapped}
+ return $x
+} -cleanup {
+ destroy .f
+} -result {created mapped modified replaced unmapped mapped off-screen unmapped}
+
-test textWind-13.1 {EmbWinBboxProc procedure} {
+test textWind-13.1 {EmbWinBboxProc procedure} -setup {
.t delete 1.0 end
+ destroy .f
+} -body {
.t insert 1.0 "Some sample text"
frame .f -width 5 -height 5 -bg $color
.t window create 1.2 -window .f -align top -padx 2 -pady 1
update
list [winfo geom .f] [.t bbox .f]
-} {5x5+21+6 {21 6 5 5}}
-test textWind-13.2 {EmbWinBboxProc procedure} {fonts} {
+} -cleanup {
+ destroy .f
+} -result {5x5+21+6 {21 6 5 5}}
+test textWind-13.2 {EmbWinBboxProc procedure} -constraints fonts -setup {
.t delete 1.0 end
+ destroy .f
+} -body {
.t insert 1.0 "Some sample text"
frame .f -width 5 -height 5 -bg $color
.t window create 1.2 -window .f -align center -padx 2 -pady 1
update
list [winfo geom .f] [.t bbox .f]
-} {5x5+21+9 {21 9 5 5}}
-test textWind-13.3 {EmbWinBboxProc procedure} {fonts} {
+} -cleanup {
+ destroy .f
+} -result {5x5+21+9 {21 9 5 5}}
+test textWind-13.3 {EmbWinBboxProc procedure} -constraints fonts -setup {
.t delete 1.0 end
+ destroy .f
+} -body {
.t insert 1.0 "Some sample text"
frame .f -width 5 -height 5 -bg $color
.t window create 1.2 -window .f -align baseline -padx 2 -pady 1
update
list [winfo geom .f] [.t bbox .f]
-} {5x5+21+10 {21 10 5 5}}
-test textWind-13.4 {EmbWinBboxProc procedure} {fonts} {
+} -cleanup {
+ destroy .f
+} -result {5x5+21+10 {21 10 5 5}}
+test textWind-13.4 {EmbWinBboxProc procedure} -constraints fonts -setup {
.t delete 1.0 end
+ destroy .f
+} -body {
.t insert 1.0 "Some sample text"
frame .f -width 5 -height 5 -bg $color
.t window create 1.2 -window .f -align bottom -padx 2 -pady 1
update
list [winfo geom .f] [.t bbox .f]
-} {5x5+21+12 {21 12 5 5}}
-test textWind-13.5 {EmbWinBboxProc procedure} {fonts} {
+} -cleanup {
+ destroy .f
+} -result {5x5+21+12 {21 12 5 5}}
+test textWind-13.5 {EmbWinBboxProc procedure} -constraints fonts -setup {
.t delete 1.0 end
+ destroy .f
+} -body {
.t insert 1.0 "Some sample text"
frame .f -width 5 -height 5 -bg $color
.t window create 1.2 -window .f -align top -padx 2 -pady 1 -stretch 1
update
list [winfo geom .f] [.t bbox .f]
-} {5x11+21+6 {21 6 5 11}}
-test textWind-13.6 {EmbWinBboxProc procedure} {fonts} {
+} -cleanup {
+ destroy .f
+} -result {5x11+21+6 {21 6 5 11}}
+test textWind-13.6 {EmbWinBboxProc procedure} -constraints fonts -setup {
.t delete 1.0 end
+ destroy .f
+} -body {
.t insert 1.0 "Some sample text"
frame .f -width 5 -height 5 -bg $color
.t window create 1.2 -window .f -align center -padx 2 -pady 1 -stretch 1
update
list [winfo geom .f] [.t bbox .f]
-} {5x11+21+6 {21 6 5 11}}
-test textWind-13.7 {EmbWinBboxProc procedure} {fonts} {
+} -cleanup {
+ destroy .f
+} -result {5x11+21+6 {21 6 5 11}}
+test textWind-13.7 {EmbWinBboxProc procedure} -constraints fonts -setup {
.t delete 1.0 end
+ destroy .f
+} -body {
.t insert 1.0 "Some sample text"
frame .f -width 5 -height 5 -bg $color
.t window create 1.2 -window .f -align baseline -padx 2 -pady 1 -stretch 1
update
list [winfo geom .f] [.t bbox .f]
-} {5x9+21+6 {21 6 5 9}}
-test textWind-13.8 {EmbWinBboxProc procedure} {fonts} {
+} -cleanup {
+ destroy .f
+} -result {5x9+21+6 {21 6 5 9}}
+test textWind-13.8 {EmbWinBboxProc procedure} -constraints fonts -setup {
.t delete 1.0 end
+ destroy .f
+} -body {
.t insert 1.0 "Some sample text"
frame .f -width 5 -height 5 -bg $color
.t window create 1.2 -window .f -align bottom -padx 2 -pady 1 -stretch 1
update
list [winfo geom .f] [.t bbox .f]
-} {5x11+21+6 {21 6 5 11}}
-test textWind-13.9 {EmbWinBboxProc procedure, spacing options} {fonts} {
+} -cleanup {
+ destroy .f
+} -result {5x11+21+6 {21 6 5 11}}
+test textWind-13.9 {EmbWinBboxProc procedure, spacing options} -constraints {
+ fonts
+} -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
.t configure -spacing1 5 -spacing3 2
.t delete 1.0 end
.t insert 1.0 "Some sample text"
@@ -744,11 +1133,15 @@ test textWind-13.9 {EmbWinBboxProc procedure, spacing options} {fonts} {
.t window create 1.2 -window .f -align center -padx 2 -pady 1
update
list [winfo geom .f] [.t bbox .f]
-} {5x5+21+14 {21 14 5 5}}
-.t configure -spacing1 0 -spacing2 0 -spacing3 0
+} -cleanup {
+ destroy .f
+} -result {5x5+21+14 {21 14 5 5}}
+
-test textWind-14.1 {EmbWinDelayedUnmap procedure} {
+test textWind-14.1 {EmbWinDelayedUnmap procedure} -setup {
.t delete 1.0 end
+ destroy .f
+} -body {
.t insert 1.0 "Some sample text"
frame .f -width 30 -height 20 -bg $color
.t window create 1.2 -window .f
@@ -760,11 +1153,14 @@ test textWind-14.1 {EmbWinDelayedUnmap procedure} {
.t window configure .f -window {}
lappend x updated
update
- set x
-} {modified removed unmapped updated}
-catch {destroy .f}
-test textWind-14.2 {EmbWinDelayedUnmap procedure} {
+ return $x
+} -cleanup {
+ destroy .f
+} -result {modified removed unmapped updated}
+test textWind-14.2 {EmbWinDelayedUnmap procedure} -setup {
.t delete 1.0 end
+ destroy .f
+} -body {
.t insert 1.0 "Some sample text"
frame .f -width 30 -height 20 -bg $color
.t window create 1.2 -window .f
@@ -776,10 +1172,14 @@ test textWind-14.2 {EmbWinDelayedUnmap procedure} {
.t delete .f
lappend x updated
update
- set x
-} {modified deleted updated}
-test textWind-14.3 {EmbWinDelayedUnmap procedure} {
+ return $x
+} -cleanup {
+ destroy .f
+} -result {modified deleted updated}
+test textWind-14.3 {EmbWinDelayedUnmap procedure} -setup {
.t delete 1.0 end
+ destroy .f
+} -body {
.t insert 1.0 "Some sample text\nAnother line\n3\n4\n5\n6\n7\n8\n9"
frame .f -width 30 -height 20 -bg $color
.t window create 1.2 -window .f
@@ -788,9 +1188,13 @@ test textWind-14.3 {EmbWinDelayedUnmap procedure} {
set result [winfo ismapped .f]
update ; after 10
list $result [winfo ismapped .f]
-} {1 0}
-test textWind-14.4 {EmbWinDelayedUnmap procedure} {
+} -cleanup {
+ destroy .f
+} -result {1 0}
+test textWind-14.4 {EmbWinDelayedUnmap procedure} -setup {
.t delete 1.0 end
+ destroy .t.f
+} -body {
.t insert 1.0 "Some sample text\nAnother line\n3\n4\n5\n6\n7\n8\n9"
frame .t.f -width 30 -height 20 -bg $color
.t window create 1.2 -window .t.f
@@ -799,27 +1203,38 @@ test textWind-14.4 {EmbWinDelayedUnmap procedure} {
set result [winfo ismapped .t.f]
update
list $result [winfo ismapped .t.f]
-} {1 0}
-catch {destroy .t.f}
-catch {destroy .f}
+} -cleanup {
+ destroy .t.f
+} -result {1 0}
-test textWind-15.1 {TkTextWindowIndex procedure} {
- list [catch {.t index .foo} msg] $msg
-} {1 {bad text index ".foo"}}
-test textWind-15.2 {TkTextWindowIndex procedure} {fonts} {
- .t configure -wrap none
+
+test textWind-15.1 {TkTextWindowIndex procedure} -setup {
.t delete 1.0 end
+} -body {
+ .t index .foo
+} -returnCodes error -result {bad text index ".foo"}
+test textWind-15.2 {TkTextWindowIndex procedure} -constraints fonts -setup {
+ .t delete 1.0 end
+ destroy .f
+} -body {
+ .t configure -spacing1 0 -spacing2 0 -spacing3 0 \
+ -wrap none
.t insert 1.0 "Some sample text"
frame .f -width 30 -height 20 -bg $color
.t window create 1.6 -window .f
.t tag add a 1.1
.t tag add a 1.3
list [.t index .f] [.t bbox 1.7]
-} {1.6 {77 8 7 13}}
+} -cleanup {
+ destroy .f
+} -result {1.6 {77 8 7 13}}
-test textWind-16.1 {EmbWinTextStructureProc procedure} {
- .t configure -wrap none
+
+test textWind-16.1 {EmbWinTextStructureProc procedure} -setup {
.t delete 1.0 end
+ destroy .f
+} -body {
+ .t configure -wrap none
.t insert 1.0 "Some sample text"
frame .f -width 30 -height 20 -bg $color
.t window create 1.6 -window .f
@@ -827,11 +1242,15 @@ test textWind-16.1 {EmbWinTextStructureProc procedure} {
pack forget .t
update
winfo ismapped .f
-} 0
-pack .t
-test textWind-16.2 {EmbWinTextStructureProc procedure} {
- .t configure -wrap none
- .t delete 1.0 end
+} -cleanup {
+ pack .t
+} -result 0
+test textWind-16.2 {EmbWinTextStructureProc procedure} -setup {
+ .t delete 1.0 end
+ destroy .f .f2
+} -body {
+ .t configure -spacing1 0 -spacing2 0 -spacing3 0 \
+ -wrap none
.t insert 1.0 "Some sample text"
frame .f -width 30 -height 20 -bg $color
.t window create 1.6 -window .f
@@ -842,21 +1261,26 @@ test textWind-16.2 {EmbWinTextStructureProc procedure} {
pack .f2 -before .t
update
lappend result [winfo geom .f] [.t bbox .f]
-} {30x20+47+5 {47 5 30 20} 30x20+47+35 {47 5 30 20}}
-catch {destroy .f2}
-test textWind-16.3 {EmbWinTextStructureProc procedure} {
- .t configure -wrap none
+} -cleanup {
+ destroy .f .f2
+} -result {30x20+47+5 {47 5 30 20} 30x20+47+35 {47 5 30 20}}
+test textWind-16.3 {EmbWinTextStructureProc procedure} -setup {
.t delete 1.0 end
+} -body {
+ .t configure -wrap none
.t insert 1.0 "Some sample text"
.t window create 1.6
update
pack forget .t
update
-} {}
-pack .t
-test textWind-16.4 {EmbWinTextStructureProc procedure} {
- .t configure -wrap none
+} -cleanup {
+ pack .t
+} -result {}
+test textWind-16.4 {EmbWinTextStructureProc procedure} -setup {
.t delete 1.0 end
+} -body {
+ .t configure -spacing1 0 -spacing2 0 -spacing3 0 \
+ -wrap none
.t insert 1.0 "Some sample text"
frame .t.f -width 30 -height 20 -bg $color
.t window create 1.6 -window .t.f
@@ -864,13 +1288,15 @@ test textWind-16.4 {EmbWinTextStructureProc procedure} {
pack forget .t
update
list [winfo ismapped .t.f] [.t bbox .t.f]
-} {1 {47 5 30 20}}
-pack .t
+} -cleanup {
+ pack .t
+} -result {1 {47 5 30 20}}
-test textWind-17.1 {peer widgets and embedded windows} {
- catch {destroy .t .tt}
+
+test textWind-17.1 {peer widgets and embedded windows} -setup {
+ destroy .t .tt .f
+} -body {
pack [text .t]
- .t delete 1.0 end
.t insert end "Line 1"
frame .f -width 20 -height 10 -bg blue
.t window create 1.3 -window .f
@@ -879,12 +1305,12 @@ test textWind-17.1 {peer widgets and embedded windows} {
update ; update
destroy .t .tt
winfo exists .f
-} {0}
+} -result {0}
-test textWind-17.2 {peer widgets and embedded windows} {
- catch {destroy .t .f}
+test textWind-17.2 {peer widgets and embedded windows} -setup {
+ destroy .t .f .tt
+} -body {
pack [text .t]
- .t delete 1.0 end
.t insert end "Line 1\nLine 2"
frame .f -width 20 -height 10 -bg blue
.t window create 1.4 -window .f
@@ -895,10 +1321,11 @@ test textWind-17.2 {peer widgets and embedded windows} {
.tt.t insert 1.0 "foo"
update
destroy .tt
-} {}
+} -result {}
-test textWind-17.3 {peer widget and -create} {
- catch {destroy .t}
+test textWind-17.3 {peer widget and -create} -setup {
+ destroy .t .tt
+} -body {
pack [text .t]
.t delete 1.0 end
.t insert 1.0 "Some sample text"
@@ -908,10 +1335,12 @@ test textWind-17.3 {peer widget and -create} {
.t window create 1.2 -create {frame %W.f -width 10 -height 20 -bg blue}
update
destroy .t .tt
-} {}
+} -result {}
-test textWind-17.4 {peer widget deleted one window shouldn't delete others} {
- catch {destroy .t .tt}
+test textWind-17.4 {peer widget deleted one window shouldn't delete others} -setup {
+ destroy .t .tt
+ set res {}
+} -body {
pack [text .t]
.t delete 1.0 end
.t insert 1.0 "Some sample text"
@@ -920,14 +1349,16 @@ test textWind-17.4 {peer widget deleted one window shouldn't delete others} {
.t window create 1.2 -create {frame %W.f -width 10 -height 20 -bg blue}
update ; update
destroy .tt
- set res {}
lappend res [.t get 1.2]
update
lappend res [.t get 1.2]
-} {{} {}}
+} -cleanup {
+ destroy .t
+} -result {{} {}}
-test textWind-17.5 {peer widget window configuration} {
- catch {destroy .t .tt}
+test textWind-17.5 {peer widget window configuration} -setup {
+ destroy .t .tt
+} -body {
pack [text .t]
.t delete 1.0 end
.t insert 1.0 "Some sample text"
@@ -935,13 +1366,14 @@ test textWind-17.5 {peer widget window configuration} {
pack [.t peer create .tt.t]
.t window create 1.2 -create {frame %W.f -width 10 -height 20 -bg blue}
update ; update
- set res [list [.t window cget 1.2 -window] [.tt.t window cget 1.2 -window]]
+ list [.t window cget 1.2 -window] [.tt.t window cget 1.2 -window]
+} -cleanup {
destroy .tt .t
- set res
-} {.t.f .tt.t.f}
+} -result {.t.f .tt.t.f}
-test textWind-17.6 {peer widget window configuration} {
- catch {destroy .t .tt}
+test textWind-17.6 {peer widget window configuration} -setup {
+ destroy .t .tt
+} -body {
pack [text .t]
.t delete 1.0 end
.t insert 1.0 "Some sample text"
@@ -949,14 +1381,15 @@ test textWind-17.6 {peer widget window configuration} {
pack [.t peer create .tt.t]
.t window create 1.2 -create {frame %W.f -width 10 -height 20 -bg blue}
update ; update
- set res [list [.t window configure 1.2 -window] \
- [.tt.t window configure 1.2 -window]]
+ list [.t window configure 1.2 -window] \
+ [.tt.t window configure 1.2 -window]
+} -cleanup {
destroy .tt .t
- set res
-} {{-window {} {} {} .t.f} {-window {} {} {} .tt.t.f}}
+} -result {{-window {} {} {} .t.f} {-window {} {} {} .tt.t.f}}
-test textWind-17.7 {peer widget window configuration} {
- catch {destroy .t .tt}
+test textWind-17.7 {peer widget window configuration} -setup {
+ destroy .t .tt
+} -body {
pack [text .t]
.t delete 1.0 end
.t insert 1.0 "Some sample text"
@@ -964,13 +1397,14 @@ test textWind-17.7 {peer widget window configuration} {
pack [.t peer create .tt.t]
.t window create 1.2 -window [frame .t.f -width 10 -height 20 -bg blue]
update ; update
- set res [list [.t window cget 1.2 -window] [.tt.t window cget 1.2 -window]]
+ list [.t window cget 1.2 -window] [.tt.t window cget 1.2 -window]
+} -cleanup {
destroy .tt .t
- set res
-} {.t.f {}}
+} -result {.t.f {}}
-test textWind-17.8 {peer widget window configuration} {
- catch {destroy .t .tt}
+test textWind-17.8 {peer widget window configuration} -setup {
+ destroy .t .tt
+} -body {
pack [text .t]
.t delete 1.0 end
.t insert 1.0 "Some sample text"
@@ -978,14 +1412,15 @@ test textWind-17.8 {peer widget window configuration} {
pack [.t peer create .tt.t]
.t window create 1.2 -window [frame .t.f -width 10 -height 20 -bg blue]
update ; update
- set res [list [.t window configure 1.2 -window] \
- [.tt.t window configure 1.2 -window]]
+ list [.t window configure 1.2 -window] \
+ [.tt.t window configure 1.2 -window]
+} -cleanup {
destroy .tt .t
- set res
-} {{-window {} {} {} .t.f} {-window {} {} {} {}}}
+} -result {{-window {} {} {} .t.f} {-window {} {} {} {}}}
-test textWind-17.8a {peer widget window configuration} {
- catch {destroy .t .tt}
+test textWind-17.9 {peer widget window configuration} -setup {
+ destroy .t .tt
+} -body {
pack [text .t]
.t delete 1.0 end
.t insert 1.0 "Some sample text"
@@ -994,14 +1429,14 @@ test textWind-17.8a {peer widget window configuration} {
.t window create 1.2 -window [frame .t.f -width 10 -height 20 -bg blue]
update ; update
.tt.t window configure 1.2 -window [frame .tt.t.f -width 10 -height 20 -bg red]
- set res [list [.t window configure 1.2 -window] \
- [.tt.t window configure 1.2 -window]]
+ list [.t window configure 1.2 -window] [.tt.t window configure 1.2 -window]
+} -cleanup {
destroy .tt .t
- set res
-} {{-window {} {} {} .t.f} {-window {} {} {} .tt.t.f}}
+} -result {{-window {} {} {} .t.f} {-window {} {} {} .tt.t.f}}
-test textWind-17.9 {peer widget window configuration} {
- catch {destroy .t .tt}
+test textWind-17.10 {peer widget window configuration} -setup {
+ destroy .t .tt
+} -body {
pack [text .t]
.t delete 1.0 end
.t insert 1.0 "Some sample text"
@@ -1015,15 +1450,14 @@ test textWind-17.9 {peer widget window configuration} {
.tt.t window configure 1.2 -window {}
.t window configure 1.2 -window {}
set res [list [.t window configure 1.2 -window] \
- [.tt.t window configure 1.2 -window]]
+ [.tt.t window configure 1.2 -window]]
update
lappend res [.t window configure 1.2 -window] \
- [.tt.t window configure 1.2 -window]
+ [.tt.t window configure 1.2 -window]
+} -cleanup {
destroy .tt .t
- set res
-} {{-window {} {} {} {}} {-window {} {} {} {}} {-window {} {} {} .t.f} {-window {} {} {} .tt.t.f}}
+} -result {{-window {} {} {} {}} {-window {} {} {} {}} {-window {} {} {} .t.f} {-window {} {} {} .tt.t.f}}
-catch {destroy .t}
option clear
# cleanup
diff --git a/tests/tk.test b/tests/tk.test
index 02b4257..748a6cf 100644
--- a/tests/tk.test
+++ b/tests/tk.test
@@ -5,135 +5,147 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2002 ActiveState Corporation.
-package require tcltest 2.1
+package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
+namespace import -force tcltest::test
-test tk-1.1 {tk command: general} \
- -body {tk} -returnCodes 1 \
- -result {wrong # args: should be "tk option ?arg?"}
-test tk-1.2 {tk command: general} \
- -body {tk xyz} -returnCodes 1 \
- -result {bad option "xyz": must be appname, caret, scaling, useinputmethods, windowingsystem, or inactive}
+test tk-1.1 {tk command: general} -body {
+ tk
+} -returnCodes error -result {wrong # args: should be "tk subcommand ?arg ...?"}
+test tk-1.2 {tk command: general} -body {
+ tk xyz
+} -returnCodes error -result {unknown or ambiguous subcommand "xyz": must be appname, busy, caret, fontchooser, inactive, scaling, useinputmethods, or windowingsystem}
+# Value stored to restore default settings after 2.* tests
set appname [tk appname]
-test tk-2.1 {tk command: appname} {
- list [catch {tk appname xyz abc} msg] $msg
-} {1 {wrong # args: should be "tk appname ?newName?"}}
-test tk-2.2 {tk command: appname} {
+test tk-2.1 {tk command: appname} -body {
+ tk appname xyz abc
+} -returnCodes error -result {wrong # args: should be "tk appname ?newName?"}
+test tk-2.2 {tk command: appname} -body {
tk appname foobazgarply
-} {foobazgarply}
-test tk-2.3 {tk command: appname} unix {
+} -result {foobazgarply}
+test tk-2.3 {tk command: appname} -constraints unix -body {
tk appname bazfoogarply
expr {[lsearch -exact [winfo interps] [tk appname]] >= 0}
-} {1}
-test tk-2.4 {tk command: appname} {
- tk appname $appname
-} $appname
+} -result {1}
+test tk-2.4 {tk command: appname} -body {
+ tk appname [tk appname]
+} -result [tk appname]
tk appname $appname
+# Value stored to restore default settings after 3.* tests
set scaling [tk scaling]
-test tk-3.1 {tk command: scaling} {
- list [catch {tk scaling -displayof} msg] $msg
-} {1 {value for "-displayof" missing}}
-test tk-3.2 {tk command: scaling: get current} {
+test tk-3.1 {tk command: scaling} -body {
+ tk scaling -displayof
+} -returnCodes error -result {value for "-displayof" missing}
+test tk-3.2 {tk command: scaling: get current} -body {
tk scaling 1
format %.2g [tk scaling]
-} 1
-test tk-3.3 {tk command: scaling: get current} {
+} -result 1
+test tk-3.3 {tk command: scaling: get current} -body {
tk scaling -displayof . 1.25
format %.3g [tk scaling]
-} 1.25
-test tk-3.4 {tk command: scaling: set new} {
- list [catch {tk scaling xyz} msg] $msg
-} {1 {expected floating-point number but got "xyz"}}
-test tk-3.5 {tk command: scaling: set new} {
- list [catch {tk scaling -displayof . xyz} msg] $msg
-} {1 {expected floating-point number but got "xyz"}}
-test tk-3.6 {tk command: scaling: set new} {
+} -result 1.25
+test tk-3.4 {tk command: scaling: set new} -body {
+ tk scaling xyz
+} -returnCodes error -result {expected floating-point number but got "xyz"}
+test tk-3.5 {tk command: scaling: set new} -body {
+ tk scaling -displayof . xyz
+} -returnCodes error -result {expected floating-point number but got "xyz"}
+test tk-3.6 {tk command: scaling: set new} -body {
tk scaling 1
format %.2g [tk scaling]
-} 1
-test tk-3.7 {tk command: scaling: set new} {
+} -result 1
+test tk-3.7 {tk command: scaling: set new} -body {
tk scaling -displayof . 1.25
format %.3g [tk scaling]
-} 1.25
-test tk-3.8 {tk command: scaling: negative} {
+} -result 1.25
+test tk-3.8 {tk command: scaling: negative} -body {
tk scaling -1
expr {[tk scaling] > 0}
-} {1}
-test tk-3.9 {tk command: scaling: too big} {
+} -result {1}
+test tk-3.9 {tk command: scaling: too big} -body {
tk scaling 1000000
expr {[tk scaling] < 10000}
-} {1}
-test tk-3.10 {tk command: scaling: widthmm} {
+} -result {1}
+test tk-3.10 {tk command: scaling: widthmm} -body {
tk scaling 1.25
- expr {int((25.4*[winfo screenwidth .])/(72*1.25)+0.5)-[winfo screenmmwidth .]}
-} {0}
-test tk-3.11 {tk command: scaling: heightmm} {
+ expr {int((25.4*[winfo screenwidth .])/(72*1.25) + 0.5) \
+ - [winfo screenmmwidth .]}
+} -result {0}
+test tk-3.11 {tk command: scaling: heightmm} -body {
tk scaling 1.25
- expr {int((25.4*[winfo screenheight .])/(72*1.25)+0.5)-[winfo screenmmheight .]}
-} {0}
+ expr {int((25.4*[winfo screenheight .])/(72*1.25) + 0.5) \
+ - [winfo screenmmheight .]}
+} -result {0}
tk scaling $scaling
+# Value stored to restore default settings after 4.* tests
set useim [tk useinputmethods]
-test tk-4.1 {tk command: useinputmethods} {
- list [catch {tk useinputmethods -displayof} msg] $msg
-} {1 {value for "-displayof" missing}}
-test tk-4.2 {tk command: useinputmethods: get current} {
+test tk-4.1 {tk command: useinputmethods} -body {
+ tk useinputmethods -displayof
+} -returnCodes error -result {value for "-displayof" missing}
+test tk-4.2 {tk command: useinputmethods: get current} -body {
+ tk useinputmethods no
+} -cleanup {
+ tk useinputmethods $useim
+} -result 0
+test tk-4.3 {tk command: useinputmethods: get current} -body {
tk useinputmethods no
-} 0
-test tk-4.3 {tk command: useinputmethods: get current} {
tk useinputmethods -displayof .
-} 0
-test tk-4.4 {tk command: useinputmethods: set new} {
- list [catch {tk useinputmethods xyz} msg] $msg
-} {1 {expected boolean value but got "xyz"}}
-test tk-4.5 {tk command: useinputmethods: set new} {
- list [catch {tk useinputmethods -displayof . xyz} msg] $msg
-} {1 {expected boolean value but got "xyz"}}
-test tk-4.6 {tk command: useinputmethods: set new} unix {
- # This isn't really a test, but more of a check...
- # The answer is what was given, because we may be on a Unix
- # system that doesn't have the XIM stuff
+} -cleanup {
+ tk useinputmethods $useim
+} -result 0
+test tk-4.4 {tk command: useinputmethods: set new} -body {
+ tk useinputmethods xyz
+} -returnCodes error -result {expected boolean value but got "xyz"}
+test tk-4.5 {tk command: useinputmethods: set new} -body {
+ tk useinputmethods -displayof . xyz
+} -returnCodes error -result {expected boolean value but got "xyz"}
+test tk-4.6 {tk command: useinputmethods: set new} -body {
+ # This isn't really a test, but more of a check... The answer is what was
+ # given, because we may be on a Unix system that doesn't have the XIM
+ # stuff
if {[tk useinputmethods 1] == 0} {
puts "this wish doesn't have XIM (X Input Methods) support"
}
- set useim
-} $useim
-test tk-4.7 {tk command: useinputmethods: set new} win {
- # Mac and Windows don't have X Input Methods, so this should
- # always return 0
+ return $useim
+} -result $useim
+test tk-4.7 {tk command: useinputmethods: set new} -constraints win -body {
+ # Mac and Windows don't have X Input Methods, so this should always return
+ # 0
tk useinputmethods 1
-} 0
-tk useinputmethods $useim
+} -cleanup {
+ tk useinputmethods $useim
+} -result 0
-test tk-5.1 {tk caret} {
- list [catch {tk caret} msg] $msg
-} {1 {wrong # args: should be "tk caret window ?-x x? ?-y y? ?-height height?"}}
-test tk-5.2 {tk caret} {
- list [catch {tk caret bogus} msg] $msg
-} {1 {bad window path name "bogus"}}
-test tk-5.3 {tk caret} {
- list [catch {tk caret . -foo} msg] $msg
-} {1 {bad caret option "-foo": must be -x, -y, or -height}}
-test tk-5.4 {tk caret} {
- list [catch {tk caret . -x 0 -y} msg] $msg
-} {1 {wrong # args: should be "tk caret window ?-x x? ?-y y? ?-height height?"}}
-test tk-5.5 {tk caret} {
- list [catch {tk caret . -x 10 -y 11 -h 12; tk caret .} msg] $msg
-} {0 {-height 12 -x 10 -y 11}}
-test tk-5.6 {tk caret} {
- list [catch {tk caret . -x 20 -y 25 -h 30; tk caret . -hei} msg] $msg
-} {0 30}
+test tk-5.1 {tk caret} -body {
+ tk caret
+} -returnCodes error -result {wrong # args: should be "tk caret window ?-x x? ?-y y? ?-height height?"}
+test tk-5.2 {tk caret} -body {
+ tk caret bogus
+} -returnCodes error -result {bad window path name "bogus"}
+test tk-5.3 {tk caret} -body {
+ tk caret . -foo
+} -returnCodes error -result {bad caret option "-foo": must be -x, -y, or -height}
+test tk-5.4 {tk caret} -body {
+ tk caret . -x 0 -y
+} -returnCodes error -result {wrong # args: should be "tk caret window ?-x x? ?-y y? ?-height height?"}
+test tk-5.5 {tk caret} -body {
+ tk caret . -x 10 -y 11 -h 12; tk caret .
+} -result {-height 12 -x 10 -y 11}
+test tk-5.6 {tk caret} -body {
+ tk caret . -x 20 -y 25 -h 30; tk caret . -hei
+} -result {30}
# tk inactive
test tk-6.1 {tk inactive} -body {
string is integer [tk inactive]
} -result 1
test tk-6.2 {tk inactive reset} -body {
- catch {tk inactive reset}
-} -result 0
+ tk inactive reset
+} -returnCodes ok -match glob -result *
test tk-6.3 {tk inactive wrong argument} -body {
tk inactive foo
} -returnCodes 1 -result {bad option "foo": must be reset}
@@ -148,16 +160,24 @@ test tk-6.5 {tk inactive} -body {
expr {$i == -1 || ( $i > 90 && $i < 200 )}
} -result 1
-# tk inactive in safe interpreters
-safe::interpCreate foo
-safe::loadTk foo
test tk-7.1 {tk inactive in a safe interpreter} -body {
+# tk inactive in safe interpreters
+ safe::interpCreate foo
+ safe::loadTk foo
foo eval {tk inactive}
+} -cleanup {
+ ::safe::interpDelete foo
} -result -1
test tk-7.2 {tk inactive reset in a safe interpreter} -body {
+# tk inactive in safe interpreters
+ safe::interpCreate foo
+ safe::loadTk foo
foo eval {tk inactive reset}
+} -cleanup {
+ ::safe::interpDelete foo
} -returnCodes 1 -result {resetting the user inactivity timer is not allowed in a safe interpreter}
-::safe::interpDelete foo
+
+# tests of [tk busy] in busy.test
# cleanup
cleanupTests
diff --git a/tests/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..8aa9ac3 100644
--- a/tests/winDialog.test
+++ b/tests/winDialog.test
@@ -7,8 +7,9 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 1998-1999 ActiveState Corporation.
-package require tcltest 2.1
-eval tcltest::configure $argv
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::configure {*}$argv
tcltest::loadTestedCommands
if {[testConstraint testwinevent]} {
@@ -31,6 +32,7 @@ proc start {arg} {
proc then {cmd} {
set ::command $cmd
set ::dialogresult {}
+ set ::testfont {}
afterbody
vwait ::dialogresult
@@ -39,12 +41,12 @@ proc then {cmd} {
proc afterbody {} {
if {$::tk_dialog == 0} {
- if {[incr ::iter_after] > 30} {
- set ::dialogresult ">30 iterations waiting on tk_dialog"
- return
- }
- after 150 {afterbody}
- return
+ if {[incr ::iter_after] > 30} {
+ set ::dialogresult ">30 iterations waiting on tk_dialog"
+ return
+ }
+ after 150 {afterbody}
+ return
}
uplevel #0 {set dialogresult [eval $command]}
}
@@ -70,6 +72,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 +164,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 +183,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 +194,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 {
@@ -197,7 +207,7 @@ test winDialog-5.3 {GetFileName: many arguments} -constraints {
} -body {
start {tk_getOpenFile -initialdir c:/ -parent . -title test -initialfile foo}
then {
- Click cancel
+ Click cancel
}
} -result {0}
test winDialog-5.4 {GetFileName: Tcl_GetIndexFromObj() != TCL_OK} -constraints {
@@ -210,7 +220,7 @@ test winDialog-5.5 {GetFileName: Tcl_GetIndexFromObj() == TCL_OK} -constraints {
} -body {
start {tk_getOpenFile -title bar}
then {
- Click cancel
+ Click cancel
}
} -result {0}
test winDialog-5.6 {GetFileName: valid option, but missing value} -constraints {
@@ -222,7 +232,7 @@ test winDialog-5.7 {GetFileName: extension begins with .} -constraints {
nt testwinevent
} -body {
# if (string[0] == '.') {
-# string++;
+# string++;
# }
start {set x [tk_getSaveFile -defaultextension .foo -title Save]}
@@ -234,7 +244,7 @@ test winDialog-5.7 {GetFileName: extension begins with .} -constraints {
Click ok
}
}
- return [string totitle $x]$msg
+ string totitle $x$msg
} -cleanup {
unset msg
} -result [string totitle [file join [pwd] bar.foo]]
@@ -250,26 +260,26 @@ test winDialog-5.8 {GetFileName: extension doesn't begin with .} -constraints {
Click ok
}
}
- return [string totitle $x]$msg
+ string totitle $x$msg
} -cleanup {
unset msg
} -result [string totitle [file join [pwd] 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
+ set x [GetText 0x470]
+ Click cancel
}
return $x
} -result {foo files (*.foo)}
test winDialog-5.10 {GetFileName: file types: MakeFilter() fails} -constraints {
nt
} -body {
-# if (MakeFilter(interp, string, &utfFilterString) != TCL_OK)
+# if (MakeFilter(interp, string, &utfFilterString) != TCL_OK)
tk_getSaveFile -filetypes {{"foo" .foo FOO}}
} -returnCodes error -result {bad Macintosh file type "FOO"}
@@ -277,13 +287,13 @@ if {[info exists ::env(TEMP)]} {
test winDialog-5.11 {GetFileName: initial directory} -constraints {
nt testwinevent
} -body {
-# case FILE_INITDIR:
+# case FILE_INITDIR:
start {set x [tk_getSaveFile \
-initialdir [file normalize $::env(TEMP)] \
-initialfile "12x 455" -title Foo]}
then {
- Click ok
+ Click ok
}
return $x
} -result [file join [file normalize $::env(TEMP)] "12x 455"]
@@ -291,61 +301,61 @@ test winDialog-5.11 {GetFileName: initial directory} -constraints {
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.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"]]
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]
+ set dialogresult [catch {
+ tk_getSaveFile -initialfile [string repeat a 1024] -title Long
+ } x]
}
then {
- Click ok
+ Click ok
}
list $dialogresult [string match "invalid filename *" $x]
} -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 {
@@ -355,8 +365,8 @@ test winDialog-5.18 {GetFileName: no filter specified} -constraints {
start {tk_getOpenFile -title Filter}
then {
- set x [GetText 0x470]
- Click cancel
+ set x [GetText 0x470]
+ Click cancel
}
return $x
} -result {All Files (*.*)}
@@ -370,7 +380,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,30 +392,30 @@ 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}
@@ -435,7 +445,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 +456,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.
@@ -460,7 +480,7 @@ test winDialog-9.1 {Tk_ChooseDirectoryObjCmd: no arguments} -constraints {
} -body {
start {tk_chooseDirectory}
then {
- Click cancel
+ Click cancel
}
} -result {0}
test winDialog-9.2 {Tk_ChooseDirectoryObjCmd: one argument} -constraints {
@@ -472,10 +492,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 c:/ -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 +508,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 +519,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]}
then {
- Click ok
+ Click ok
}
string tolower [set x]
} -result {c:/}
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 +659,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..876ba81 100644
--- a/tests/window.test
+++ b/tests/window.test
@@ -5,42 +5,51 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
-eval tcltest::configure $argv
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::configure {*}$argv
tcltest::loadTestedCommands
testConstraint unthreaded [expr {
(![info exist tcl_platform(threaded)] || !$tcl_platform(threaded))
}]
-namespace import -force ::tk::test::loadTkCommand
+namespace import ::tk::test::loadTkCommand
update
# XXX This file is woefully incomplete. Right now it only tests
# a few parts of a few procedures in tkWindow.c
-test window-1.1 {Tk_CreateWindowFromPath procedure, parent dead} {
+# ----------------------------------------------------------------------
+
+test window-1.1 {Tk_CreateWindowFromPath procedure, parent dead} -setup {
+ destroy .t
+} -body {
proc bgerror msg {
- global x errorInfo
- set x [list $msg $errorInfo]
+ global x errorInfo
+ set x [list $msg $errorInfo]
}
+
set x unchanged
- catch {destroy .t}
frame .t -width 100 -height 50
place .t -x 10 -y 10
bind .t <Destroy> {button .t.b -text hello; pack .t.b}
update
destroy .t
update
- rename bgerror {}
set x
-} {{can't create window: parent has been destroyed} {can't create window: parent has been destroyed
+} -cleanup {
+ rename bgerror {}
+} -result {{can't create window: parent has been destroyed} {can't create window: parent has been destroyed
while executing
"button .t.b -text hello"
(command bound to event)}}
+
# Most of the tests below don't produce meaningful results; they
# will simply dump core if there are bugs.
-test window-2.1 {Tk_DestroyWindow procedure, destroy handler deletes parent} {
+test window-2.1 {Tk_DestroyWindow procedure, destroy handler deletes parent} -setup {
+ destroy .t
+} -body {
toplevel .t -width 300 -height 200
wm geometry .t +0+0
frame .t.f -width 200 -height 200 -relief raised -bd 2
@@ -50,8 +59,10 @@ test window-2.1 {Tk_DestroyWindow procedure, destroy handler deletes parent} {
bind .t.f <Destroy> {destroy .t}
update
destroy .t.f
-} {}
-test window-2.2 {Tk_DestroyWindow procedure, destroy handler deletes parent} {
+} -result {}
+test window-2.2 {Tk_DestroyWindow procedure, destroy handler deletes parent} -setup {
+ destroy .t
+} -body {
toplevel .t -width 300 -height 200
wm geometry .t +0+0
frame .t.f -width 200 -height 200 -relief raised -bd 2
@@ -61,8 +72,10 @@ test window-2.2 {Tk_DestroyWindow procedure, destroy handler deletes parent} {
bind .t.f.f <Destroy> {destroy .t}
update
destroy .t.f
-} {}
-test window-2.3 {Tk_DestroyWindow procedure, destroy handler deletes parent} {
+} -result {}
+test window-2.3 {Tk_DestroyWindow procedure, destroy handler deletes parent} -setup {
+ destroy .f
+} -body {
frame .f -width 80 -height 120 -relief raised -bd 2
place .f -relx 0.5 -rely 0.5 -anchor center
toplevel .f.t -width 300 -height 200
@@ -73,10 +86,11 @@ test window-2.3 {Tk_DestroyWindow procedure, destroy handler deletes parent} {
place .f.t.f.f -relx 1 -rely 1 -anchor se
update
destroy .f
-} {}
+} -result {}
-test window-2.4 {Tk_DestroyWindow, cleanup half dead window at exit} \
- unixOrWin {
+test window-2.4 {Tk_DestroyWindow, cleanup half dead window at exit} -constraints {
+ unixOrWin
+} -body {
set code [loadTkCommand]
append code {
update
@@ -85,16 +99,17 @@ test window-2.4 {Tk_DestroyWindow, cleanup half dead window at exit} \
}
set script [makeFile $code script]
if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
- set error 1
+ set error 1
} else {
- set error 0
+ set error 0
}
removeFile script
list $error $msg
-} {0 {}}
+} -result {0 {}}
-test window-2.5 {Tk_DestroyWindow, cleanup half dead windows at exit} \
- unixOrWin {
+test window-2.5 {Tk_DestroyWindow, cleanup half dead windows at exit} -constraints {
+ unixOrWin
+} -body {
set code [loadTkCommand]
append code {
toplevel .t
@@ -104,16 +119,17 @@ test window-2.5 {Tk_DestroyWindow, cleanup half dead windows at exit} \
}
set script [makeFile $code script]
if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
- set error 1
+ set error 1
} else {
- set error 0
+ set error 0
}
removeFile script
list $error $msg
-} {0 {}}
+} -result {0 {}}
-test window-2.6 {Tk_DestroyWindow, cleanup half dead windows at exit} \
- unixOrWin {
+test window-2.6 {Tk_DestroyWindow, cleanup half dead windows at exit} -constraints {
+ unixOrWin
+} -body {
set code [loadTkCommand]
append code {
toplevel .t
@@ -123,16 +139,17 @@ test window-2.6 {Tk_DestroyWindow, cleanup half dead windows at exit} \
}
set script [makeFile $code script]
if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
- set error 1
+ set error 1
} else {
- set error 0
+ set error 0
}
removeFile script
list $error $msg
-} {0 {}}
+} -result {0 {}}
-test window-2.7 {Tk_DestroyWindow, cleanup half dead windows at exit} \
- unixOrWin {
+test window-2.7 {Tk_DestroyWindow, cleanup half dead windows at exit} -constraints {
+ unixOrWin
+} -body {
set code [loadTkCommand]
append code {
toplevel .t
@@ -143,16 +160,17 @@ test window-2.7 {Tk_DestroyWindow, cleanup half dead windows at exit} \
}
set script [makeFile $code script]
if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
- set error 1
+ set error 1
} else {
- set error 0
+ set error 0
}
removeFile script
list $error $msg
-} {0 {}}
+} -result {0 {}}
-test window-2.8 {Tk_DestroyWindow, cleanup half dead windows at exit} \
- unixOrWin {
+test window-2.8 {Tk_DestroyWindow, cleanup half dead windows at exit} -constraints {
+ unixOrWin
+} -body {
set code [loadTkCommand]
append code {
toplevel .t1
@@ -166,17 +184,18 @@ test window-2.8 {Tk_DestroyWindow, cleanup half dead windows at exit} \
}
set script [makeFile $code script]
if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
- set error 1
+ set error 1
} else {
- set error 0
+ set error 0
}
removeFile script
list $error $msg
-} {0 {}}
+} -result {0 {}}
# window-2.9 deadlocks threaded Tk [Bug 1715716]
-test window-2.9 {Tk_DestroyWindow, Destroy bindings
- evaluated after exit} {unixOrWin unthreaded} {
+test window-2.9 {Tk_DestroyWindow, Destroy bindings evaluated after exit} -constraints {
+ unixOrWin unthreaded
+} -body {
set code [loadTkCommand]
append code {
toplevel .t1
@@ -188,17 +207,18 @@ test window-2.9 {Tk_DestroyWindow, Destroy bindings
}
set script [makeFile $code script]
if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
- set error 1
+ set error 1
} else {
- set error 0
+ set error 0
}
removeFile script
list $error $msg
-} {0 {Destroy .t2
+} -result {0 {Destroy .t2
Destroy .t1}}
-test window-2.10 {Tk_DestroyWindow, Destroy binding
- evaluated once} unixOrWin {
+test window-2.10 {Tk_DestroyWindow, Destroy binding evaluated once} -constraints {
+ unixOrWin
+} -body {
set code [loadTkCommand]
append code {
update
@@ -211,16 +231,17 @@ test window-2.10 {Tk_DestroyWindow, Destroy binding
}
set script [makeFile $code script]
if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
- set error 1
+ set error 1
} else {
- set error 0
+ set error 0
}
removeFile script
list $error $msg
-} {0 {Destroy .}}
+} -result {0 {Destroy .}}
-test window-2.11 {Tk_DestroyWindow, don't reanimate a half-dead window} \
- unixOrWin {
+test window-2.11 {Tk_DestroyWindow, don't reanimate a half-dead window} -constraints {
+ unixOrWin
+} -body {
set code [loadTkCommand]
append code {
toplevel .t1
@@ -238,17 +259,20 @@ test window-2.11 {Tk_DestroyWindow, don't reanimate a half-dead window} \
}
set script [makeFile $code script]
if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
- set error 1
+ set error 1
} else {
- set error 0
+ set error 0
}
removeFile script
list $error $msg
-} {0 YES}
+} -result {0 YES}
-test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \
- {unix testmenubar} {
- catch {destroy .t}
+
+test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} -constraints {
+ unix testmenubar
+} -setup {
+ destroy .t
+} -body {
toplevel .t -width 300 -height 200
wm geometry .t +0+0
pack [entry .t.e]
@@ -256,10 +280,14 @@ test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \
testmenubar window .t .t.f
update
# If stacking order isn't handle properly, generates an X error.
-} {}
-test window-3.2 {Tk_MakeWindowExist procedure, stacking order and menubars} \
- {unix testmenubar} {
- catch {destroy .t}
+} -cleanup {
+ destroy .t
+} -result {}
+test window-3.2 {Tk_MakeWindowExist procedure, stacking order and menubars} -constraints {
+ unix testmenubar
+} -setup {
+ destroy .t
+} -body {
toplevel .t -width 300 -height 200
wm geometry .t +0+0
pack [entry .t.e]
@@ -270,23 +298,39 @@ test window-3.2 {Tk_MakeWindowExist procedure, stacking order and menubars} \
testmenubar window .t .t.f
update
# If stacking order isn't handled properly, generates an X error.
-} {}
+} -cleanup {
+ destroy .t
+} -result {}
+
-test window-4.1 {Tk_NameToWindow procedure} {testmenubar} {
- catch {destroy .t}
- list [catch {winfo geometry .t} msg] $msg
-} {1 {bad window path name ".t"}}
-test window-4.2 {Tk_NameToWindow procedure} {testmenubar} {
- catch {destroy .t}
+test window-4.1 {Tk_NameToWindow procedure} -constraints {
+ testmenubar
+} -setup {
+ destroy .t
+} -body {
+ winfo geometry .t
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {bad window path name ".t"}
+test window-4.2 {Tk_NameToWindow procedure} -constraints {
+ testmenubar
+} -setup {
+ destroy .t
+} -body {
frame .t -width 100 -height 50
place .t -x 10 -y 10
update
- list [catch {winfo geometry .t} msg] $msg
-} {0 100x50+10+10}
+ winfo geometry .t
+} -cleanup {
+ destroy .t
+} -returnCodes ok -result {100x50+10+10}
+
-test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \
- {unix testmenubar} {
- catch {destroy .t}
+test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} -constraints {
+ unix testmenubar
+} -setup {
+ destroy .t
+} -body {
toplevel .t -width 300 -height 200
wm geometry .t +0+0
pack [entry .t.e]
@@ -297,8 +341,15 @@ test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \
lower .t.e2 .t.f
update
# If stacking order isn't handled properly, generates an X error.
-} {}
+} -cleanup {
+ destroy .t
+} -result {}
+
# cleanup
cleanupTests
return
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tests/winfo.test b/tests/winfo.test
index 4ce87eb..14c2838 100644
--- a/tests/winfo.test
+++ b/tests/winfo.test
@@ -6,8 +6,9 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
-eval tcltest::configure $argv
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::configure {*}$argv
tcltest::loadTestedCommands
# eatColors --
@@ -15,22 +16,22 @@ tcltest::loadTestedCommands
# use up all the slots in the colormap.
#
# Arguments:
-# w - Name of toplevel window to create.
-# options - Options for w, such as "-colormap new".
+# w - Name of toplevel window to create.
+# options - Options for w, such as "-colormap new".
proc eatColors {w {options ""}} {
- catch {destroy $w}
+ destroy $w
eval toplevel $w $options
wm geom $w +0+0
canvas $w.c -width 400 -height 200 -bd 0
pack $w.c
for {set y 0} {$y < 8} {incr y} {
- for {set x 0} {$x < 40} {incr x} {
- set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0]
- $w.c create rectangle [expr 10*$x] [expr 20*$y] \
- [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \
- -fill $color
- }
+ for {set x 0} {$x < 40} {incr x} {
+ set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0]
+ $w.c create rectangle [expr 10*$x] [expr 20*$y] \
+ [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \
+ -fill $color
+ }
}
update
}
@@ -38,57 +39,69 @@ proc eatColors {w {options ""}} {
# XXX - This test file is woefully incomplete. At present, only a
# few of the winfo options are tested.
-test winfo-1.1 {"winfo atom" command} {
- list [catch {winfo atom} msg] $msg
-} {1 {wrong # args: should be "winfo atom ?-displayof window? name"}}
-test winfo-1.2 {"winfo atom" command} {
- list [catch {winfo atom a b} msg] $msg
-} {1 {wrong # args: should be "winfo atom ?-displayof window? name"}}
-test winfo-1.3 {"winfo atom" command} {
- list [catch {winfo atom a b c d} msg] $msg
-} {1 {wrong # args: should be "winfo atom ?-displayof window? name"}}
-test winfo-1.4 {"winfo atom" command} {
- list [catch {winfo atom -displayof geek foo} msg] $msg
-} {1 {bad window path name "geek"}}
-test winfo-1.5 {"winfo atom" command} {
+# ----------------------------------------------------------------------
+
+test winfo-1.1 {"winfo atom" command} -body {
+ winfo atom
+} -returnCodes error -result {wrong # args: should be "winfo atom ?-displayof window? name"}
+test winfo-1.2 {"winfo atom" command} -body {
+ winfo atom a b
+} -returnCodes error -result {wrong # args: should be "winfo atom ?-displayof window? name"}
+test winfo-1.3 {"winfo atom" command} -body {
+ winfo atom a b c d
+} -returnCodes error -result {wrong # args: should be "winfo atom ?-displayof window? name"}
+test winfo-1.4 {"winfo atom" command} -body {
+ winfo atom -displayof geek foo
+} -returnCodes error -result {bad window path name "geek"}
+test winfo-1.5 {"winfo atom" command} -body {
winfo atom PRIMARY
-} 1
-test winfo-1.6 {"winfo atom" command} {
+} -result 1
+test winfo-1.6 {"winfo atom" command} -body {
winfo atom -displayof . PRIMARY
-} 1
-
-test winfo-2.1 {"winfo atomname" command} {
- list [catch {winfo atomname} msg] $msg
-} {1 {wrong # args: should be "winfo atomname ?-displayof window? id"}}
-test winfo-2.2 {"winfo atomname" command} {
- list [catch {winfo atomname a b} msg] $msg
-} {1 {wrong # args: should be "winfo atomname ?-displayof window? id"}}
-test winfo-2.3 {"winfo atomname" command} {
- list [catch {winfo atomname a b c d} msg] $msg
-} {1 {wrong # args: should be "winfo atomname ?-displayof window? id"}}
-test winfo-2.4 {"winfo atomname" command} {
- list [catch {winfo atomname -displayof geek foo} msg] $msg
-} {1 {bad window path name "geek"}}
-test winfo-2.5 {"winfo atomname" command} {
- list [catch {winfo atomname 44215} msg] $msg
-} {1 {no atom exists with id "44215"}}
-test winfo-2.6 {"winfo atomname" command} {
+} -result 1
+
+
+test winfo-2.1 {"winfo atomname" command} -body {
+ winfo atomname
+} -returnCodes error -result {wrong # args: should be "winfo atomname ?-displayof window? id"}
+test winfo-2.2 {"winfo atomname" command} -body {
+ winfo atomname a b
+} -returnCodes error -result {wrong # args: should be "winfo atomname ?-displayof window? id"}
+test winfo-2.3 {"winfo atomname" command} -body {
+ winfo atomname a b c d
+} -returnCodes error -result {wrong # args: should be "winfo atomname ?-displayof window? id"}
+test winfo-2.4 {"winfo atomname" command} -body {
+ winfo atomname -displayof geek foo
+} -returnCodes error -result {bad window path name "geek"}
+test winfo-2.5 {"winfo atomname" command} -body {
+ winfo atomname 44215
+} -returnCodes error -result {no atom exists with id "44215"}
+test winfo-2.6 {"winfo atomname" command} -body {
winfo atomname 2
-} SECONDARY
-test winfo-2.7 {"winfo atom" command} {
+} -result SECONDARY
+test winfo-2.7 {"winfo atom" command} -body {
winfo atomname -displayof . 2
-} SECONDARY
-
-test winfo-3.1 {"winfo colormapfull" command} defaultPseudocolor8 {
- list [catch {winfo colormapfull} msg] $msg
-} {1 {wrong # args: should be "winfo colormapfull window"}}
-test winfo-3.2 {"winfo colormapfull" command} defaultPseudocolor8 {
- list [catch {winfo colormapfull a b} msg] $msg
-} {1 {wrong # args: should be "winfo colormapfull window"}}
-test winfo-3.3 {"winfo colormapfull" command} defaultPseudocolor8 {
- list [catch {winfo colormapfull foo} msg] $msg
-} {1 {bad window path name "foo"}}
-test winfo-3.4 {"winfo colormapfull" command} {unix defaultPseudocolor8} {
+} -result SECONDARY
+
+
+test winfo-3.1 {"winfo colormapfull" command} -constraints {
+ defaultPseudocolor8
+} -body {
+ winfo colormapfull
+} -returnCodes error -result {wrong # args: should be "winfo colormapfull window"}
+test winfo-3.2 {"winfo colormapfull" command} -constraints {
+ defaultPseudocolor8
+} -body {
+ winfo colormapfull a b
+} -returnCodes error -result {wrong # args: should be "winfo colormapfull window"}
+test winfo-3.3 {"winfo colormapfull" command} -constraints {
+ defaultPseudocolor8
+} -body {
+ winfo colormapfull foo
+} -returnCodes error -result {bad window path name "foo"}
+test winfo-3.4 {"winfo colormapfull" command} -constraints {
+ unix defaultPseudocolor8
+} -body {
eatColors .t {-colormap new}
set result [list [winfo colormapfull .] [winfo colormapfull .t]]
.t.c delete 34
@@ -99,69 +112,103 @@ test winfo-3.4 {"winfo colormapfull" command} {unix defaultPseudocolor8} {
lappend result [winfo colormapfull .t]
destroy .t.c
lappend result [winfo colormapfull .t]
-} {0 1 0 0 1 0}
-catch {destroy .t}
-
-toplevel .t -width 550 -height 400
-frame .t.f -width 80 -height 60 -bd 2 -relief raised
-place .t.f -x 50 -y 50
-wm geom .t +0+0
-update
-test winfo-4.1 {"winfo containing" command} {
- list [catch {winfo containing 22} msg] $msg
-} {1 {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"}}
-test winfo-4.2 {"winfo containing" command} {
- list [catch {winfo containing a b c} msg] $msg
-} {1 {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"}}
-test winfo-4.3 {"winfo containing" command} {
- list [catch {winfo containing a b c d e} msg] $msg
-} {1 {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"}}
-test winfo-4.4 {"winfo containing" command} {
- list [catch {winfo containing -displayof geek 25 30} msg] $msg
-} {1 {bad window path name "geek"}}
-test winfo-4.5 {"winfo containing" command} {
+} -cleanup {
+ destroy .t
+} -result {0 1 0 0 1 0}
+
+
+
+test winfo-4.1 {"winfo containing" command} -body {
+ winfo containing 22
+} -returnCodes error -result {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"}
+test winfo-4.2 {"winfo containing" command} -body {
+ winfo containing a b c
+} -returnCodes error -result {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"}
+test winfo-4.3 {"winfo containing" command} -body {
+ winfo containing a b c d e
+} -returnCodes error -result {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"}
+test winfo-4.4 {"winfo containing" command} -body {
+ winfo containing -displayof geek 25 30
+} -returnCodes error -result {bad window path name "geek"}
+test winfo-4.5 {"winfo containing" command} -body {
+} -setup {
+ destroy .t
+} -body {
+ toplevel .t -width 550 -height 400
+ frame .t.f -width 80 -height 60 -bd 2 -relief raised
+ place .t.f -x 50 -y 50
+ wm geom .t +0+0
+ update
+
raise .t
winfo containing [winfo rootx .t.f] [winfo rooty .t.f]
-} .t.f
-test winfo-4.6 {"winfo containing" command} {nonPortable} {
+} -cleanup {
+ destroy .t
+} -result .t.f
+test winfo-4.6 {"winfo containing" command} -constraints {
+ nonPortable
+} -setup {
+ destroy .t
+} -body {
+ toplevel .t -width 550 -height 400
+ frame .t.f -width 80 -height 60 -bd 2 -relief raised
+ place .t.f -x 50 -y 50
+ wm geom .t +0+0
+ update
+
winfo containing [expr [winfo rootx .t.f]-1] [expr [winfo rooty .t.f]-1]
-} .t
-test winfo-4.7 {"winfo containing" command} {
+} -cleanup {
+ destroy .t
+} -result .t
+test winfo-4.7 {"winfo containing" command} -setup {
+ destroy .t
+} -body {
+ toplevel .t -width 550 -height 400
+ frame .t.f -width 80 -height 60 -bd 2 -relief raised
+ place .t.f -x 50 -y 50
+ wm geom .t +0+0
+ update
+
set x [winfo containing -display .t.f [expr [winfo rootx .t]+600] \
- [expr [winfo rooty .t.f]+450]]
+ [expr [winfo rooty .t.f]+450]]
expr {($x == ".") || ($x == "")}
-} {1}
-destroy .t
-
-test winfo-5.1 {"winfo interps" command} {
- list [catch {winfo interps a} msg] $msg
-} {1 {wrong # args: should be "winfo interps ?-displayof window?"}}
-test winfo-5.2 {"winfo interps" command} {
- list [catch {winfo interps a b c} msg] $msg
-} {1 {wrong # args: should be "winfo interps ?-displayof window?"}}
-test winfo-5.3 {"winfo interps" command} {
- list [catch {winfo interps -displayof geek} msg] $msg
-} {1 {bad window path name "geek"}}
-test winfo-5.4 {"winfo interps" command} unix {
- expr [lsearch -exact [winfo interps] [tk appname]] >= 0
-} {1}
-test winfo-5.5 {"winfo interps" command} unix {
- expr [lsearch -exact [winfo interps -displayof .] [tk appname]] >= 0
-} {1}
-
-test winfo-6.1 {"winfo exists" command} {
- list [catch {winfo exists} msg] $msg
-} {1 {wrong # args: should be "winfo exists window"}}
-test winfo-6.2 {"winfo exists" command} {
- list [catch {winfo exists a b} msg] $msg
-} {1 {wrong # args: should be "winfo exists window"}}
-test winfo-6.3 {"winfo exists" command} {
+} -cleanup {
+ destroy .t
+} -result {1}
+
+
+test winfo-5.1 {"winfo interps" command} -body {
+ winfo interps a
+} -returnCodes error -result {wrong # args: should be "winfo interps ?-displayof window?"}
+test winfo-5.2 {"winfo interps" command} -body {
+ winfo interps a b c
+} -returnCodes error -result {wrong # args: should be "winfo interps ?-displayof window?"}
+test winfo-5.3 {"winfo interps" command} -body {
+ winfo interps -displayof geek
+} -returnCodes error -result {bad window path name "geek"}
+test winfo-5.4 {"winfo interps" command} -constraints unix -body {
+ expr {[lsearch -exact [winfo interps] [tk appname]] >= 0}
+} -result {1}
+test winfo-5.5 {"winfo interps" command} -constraints unix -body {
+ expr {[lsearch -exact [winfo interps -displayof .] [tk appname]] >= 0}
+} -result {1}
+
+
+test winfo-6.1 {"winfo exists" command} -body {
+ winfo exists
+} -returnCodes error -result {wrong # args: should be "winfo exists window"}
+test winfo-6.2 {"winfo exists" command} -body {
+ winfo exists a b
+} -returnCodes error -result {wrong # args: should be "winfo exists window"}
+test winfo-6.3 {"winfo exists" command} -body {
winfo exists gorp
-} {0}
-test winfo-6.4 {"winfo exists" command} {
+} -result {0}
+test winfo-6.4 {"winfo exists" command} -body {
winfo exists .
-} {1}
-test winfo-6.5 {"winfo exists" command} {
+} -result {1}
+test winfo-6.5 {"winfo exists" command} -setup {
+ destroy .b
+} -body {
button .b -text "Test button"
set x [winfo exists .b]
pack .b
@@ -169,78 +216,113 @@ test winfo-6.5 {"winfo exists" command} {
bind .b <Destroy> {lappend x [winfo exists .x]}
destroy .b
lappend x [winfo exists .x]
-} {1 0 0}
-
-catch {destroy .b}
-button .b -text "Help"
-update
-test winfo-7.1 {"winfo pathname" command} {
- list [catch {winfo pathname} msg] $msg
-} {1 {wrong # args: should be "winfo pathname ?-displayof window? id"}}
-test winfo-7.2 {"winfo pathname" command} {
- list [catch {winfo pathname a b} msg] $msg
-} {1 {wrong # args: should be "winfo pathname ?-displayof window? id"}}
-test winfo-7.3 {"winfo pathname" command} {
- list [catch {winfo pathname a b c d} msg] $msg
-} {1 {wrong # args: should be "winfo pathname ?-displayof window? id"}}
-test winfo-7.4 {"winfo pathname" command} {
- list [catch {winfo pathname -displayof geek 25} msg] $msg
-} {1 {bad window path name "geek"}}
-test winfo-7.5 {"winfo pathname" command} {
- list [catch {winfo pathname xyz} msg] $msg
-} {1 {expected integer but got "xyz"}}
-test winfo-7.6 {"winfo pathname" command} {
- list [catch {winfo pathname 224} msg] $msg
-} {1 {window id "224" doesn't exist in this application}}
-test winfo-7.7 {"winfo pathname" command} {
+} -result {1 0 0}
+
+
+test winfo-7.1 {"winfo pathname" command} -body {
+ winfo pathname
+} -returnCodes error -result {wrong # args: should be "winfo pathname ?-displayof window? id"}
+test winfo-7.2 {"winfo pathname" command} -body {
+ winfo pathname a b
+} -returnCodes error -result {wrong # args: should be "winfo pathname ?-displayof window? id"}
+test winfo-7.3 {"winfo pathname" command} -body {
+ winfo pathname a b c d
+} -returnCodes error -result {wrong # args: should be "winfo pathname ?-displayof window? id"}
+test winfo-7.4 {"winfo pathname" command} -body {
+ winfo pathname -displayof geek 25
+} -returnCodes error -result {bad window path name "geek"}
+test winfo-7.5 {"winfo pathname" command} -body {
+ winfo pathname xyz
+} -returnCodes error -result {expected integer but got "xyz"}
+test winfo-7.6 {"winfo pathname" command} -body {
+ winfo pathname 224
+} -returnCodes error -result {window id "224" doesn't exist in this application}
+test winfo-7.7 {"winfo pathname" command} -setup {
+ destroy .b
+ button .b -text "Help"
+ update
+} -body {
winfo pathname -displayof .b [winfo id .]
-} {.}
-test winfo-7.8 {"winfo pathname" command} {unix testwrapper} {
+} -cleanup {
+ destroy .b
+} -result {.}
+test winfo-7.8 {"winfo pathname" command} -constraints {
+ unix testwrapper
+} -body {
winfo pathname [testwrapper .]
-} {}
+} -result {}
-test winfo-8.1 {"winfo pointerx" command} {
+
+test winfo-8.1 {"winfo pointerx" command} -setup {
+ destroy .b
+ button .b -text "Help"
+ update
+} -body {
+ catch [winfo pointerx .b]
+} -body {
catch [winfo pointerx .b]
-} 1
-test winfo-8.2 {"winfo pointery" command} {
+} -result 1
+test winfo-8.2 {"winfo pointery" command} -setup {
+ destroy .b
+ button .b -text "Help"
+ update
+} -body {
catch [winfo pointery .b]
-} 1
-test winfo-8.3 {"winfo pointerxy" command} {
+} -body {
+ catch [winfo pointerx .b]
+} -result 1
+test winfo-8.3 {"winfo pointerxy" command} -setup {
+ destroy .b
+ button .b -text "Help"
+ update
+} -body {
catch [winfo pointerxy .b]
-} 1
-
-test winfo-9.1 {"winfo viewable" command} {
- list [catch {winfo viewable} msg] $msg
-} {1 {wrong # args: should be "winfo viewable window"}}
-test winfo-9.2 {"winfo viewable" command} {
- list [catch {winfo viewable foo} msg] $msg
-} {1 {bad window path name "foo"}}
-test winfo-9.3 {"winfo viewable" command} {
+} -body {
+ catch [winfo pointerx .b]
+} -result 1
+
+
+test winfo-9.1 {"winfo viewable" command} -body {
+ winfo viewable
+} -returnCodes error -result {wrong # args: should be "winfo viewable window"}
+test winfo-9.2 {"winfo viewable" command} -body {
+ winfo viewable foo
+} -returnCodes error -result {bad window path name "foo"}
+test winfo-9.3 {"winfo viewable" command} -body {
winfo viewable .
-} {1}
-test winfo-9.4 {"winfo viewable" command} {
+} -result {1}
+test winfo-9.4 {"winfo viewable" command} -body {
wm iconify .
winfo viewable .
-} {0}
-wm deiconify .
-test winfo-9.5 {"winfo viewable" command} {
+} -cleanup {
+ wm deiconify .
+} -result {0}
+test winfo-9.5 {"winfo viewable" command} -setup {
+ deleteWindows
+} -body {
frame .f1 -width 100 -height 100 -relief raised -bd 2
place .f1 -x 0 -y 0
frame .f1.f2 -width 50 -height 50 -relief raised -bd 2
place .f1.f2 -x 0 -y 0
update
list [winfo viewable .f1] [winfo viewable .f1.f2]
-} {1 1}
-test winfo-9.6 {"winfo viewable" command} {
+} -cleanup {
+ deleteWindows
+} -result {1 1}
+test winfo-9.6 {"winfo viewable" command} -setup {
deleteWindows
+} -body {
frame .f1 -width 100 -height 100 -relief raised -bd 2
frame .f1.f2 -width 50 -height 50 -relief raised -bd 2
place .f1.f2 -x 0 -y 0
update
list [winfo viewable .f1] [winfo viewable .f1.f2]
-} {0 0}
-test winfo-9.7 {"winfo viewable" command} {
+} -cleanup {
+ deleteWindows
+} -result {0 0}
+test winfo-9.7 {"winfo viewable" command} -setup {
deleteWindows
+} -body {
frame .f1 -width 100 -height 100 -relief raised -bd 2
place .f1 -x 0 -y 0
frame .f1.f2 -width 50 -height 50 -relief raised -bd 2
@@ -248,121 +330,156 @@ test winfo-9.7 {"winfo viewable" command} {
update
wm iconify .
list [winfo viewable .f1] [winfo viewable .f1.f2]
-} {0 0}
-wm deiconify .
-deleteWindows
+} -cleanup {
+ wm deiconify .
+ deleteWindows
+} -result {0 0}
-test winfo-10.1 {"winfo visualid" command} {
- list [catch {winfo visualid} msg] $msg
-} {1 {wrong # args: should be "winfo visualid window"}}
-test winfo-10.2 {"winfo visualid" command} {
- list [catch {winfo visualid gorp} msg] $msg
-} {1 {bad window path name "gorp"}}
-test winfo-10.3 {"winfo visualid" command} {
- expr 2+[winfo visualid .]-[winfo visualid .]
-} {2}
-
-test winfo-11.1 {"winfo visualid" command} {
- list [catch {winfo visualsavailable} msg] $msg
-} {1 {wrong # args: should be "winfo visualsavailable window ?includeids?"}}
-test winfo-11.2 {"winfo visualid" command} {
- list [catch {winfo visualsavailable gorp} msg] $msg
-} {1 {bad window path name "gorp"}}
-test winfo-11.3 {"winfo visualid" command} {
- list [catch {winfo visualsavailable . includeids foo} msg] $msg
-} {1 {wrong # args: should be "winfo visualsavailable window ?includeids?"}}
-test winfo-11.4 {"winfo visualid" command} {
+
+test winfo-10.1 {"winfo visualid" command} -body {
+ winfo visualid
+} -returnCodes error -result {wrong # args: should be "winfo visualid window"}
+test winfo-10.2 {"winfo visualid" command} -body {
+ winfo visualid gorp
+} -returnCodes error -result {bad window path name "gorp"}
+test winfo-10.3 {"winfo visualid" command} -body {
+ expr {2 + [winfo visualid .] - [winfo visualid .]}
+} -result {2}
+
+
+test winfo-11.1 {"winfo visualid" command} -body {
+ winfo visualsavailable
+} -returnCodes error -result {wrong # args: should be "winfo visualsavailable window ?includeids?"}
+test winfo-11.2 {"winfo visualid" command} -body {
+ winfo visualsavailable gorp
+} -returnCodes error -result {bad window path name "gorp"}
+test winfo-11.3 {"winfo visualid" command} -body {
+ winfo visualsavailable . includeids foo
+} -returnCodes error -result {wrong # args: should be "winfo visualsavailable window ?includeids?"}
+test winfo-11.4 {"winfo visualid" command} -body {
llength [lindex [winfo visualsa .] 0]
-} {2}
-test winfo-11.5 {"winfo visualid" command} {
+} -result {2}
+test winfo-11.5 {"winfo visualid" command} -body {
llength [lindex [winfo visualsa . includeids] 0]
-} {3}
-test winfo-11.6 {"winfo visualid" command} {
+} -result {3}
+test winfo-11.6 {"winfo visualid" command} -body {
set x [lindex [lindex [winfo visualsa . includeids] 0] 2]
expr $x + 2 - $x
-} {2}
+} -result {2}
+
+
+test winfo-12.1 {GetDisplayOf procedure} -body {
+ winfo atom - foo x
+} -returnCodes error -result {wrong # args: should be "winfo atom ?-displayof window? name"}
+test winfo-12.2 {GetDisplayOf procedure} -body {
+ winfo atom -d bad_window x
+} -returnCodes error -result {bad window path name "bad_window"}
-test winfo-12.1 {GetDisplayOf procedure} {
- list [catch {winfo atom - foo x} msg] $msg
-} {1 {wrong # args: should be "winfo atom ?-displayof window? name"}}
-test winfo-12.2 {GetDisplayOf procedure} {
- list [catch {winfo atom -d bad_window x} msg] $msg
-} {1 {bad window path name "bad_window"}}
# Some embedding tests
-#
+#
+test winfo-13.1 {root coordinates of embedded toplevel} -setup {
+ deleteWindows
+} -body {
+ frame .con -container 1
+ pack .con -expand yes -fill both
+ toplevel .emb -use [winfo id .con] -bd 0 -highlightthickness 0
+ button .emb.b
+ pack .emb.b -expand yes -fill both
+ update
+
+ list rootx [expr {[winfo rootx .emb] == [winfo rootx .con]}] \
+ rooty [expr {[winfo rooty .emb] == [winfo rooty .con]}]
+} -cleanup {
+ deleteWindows
+} -result {rootx 1 rooty 1}
-proc MakeEmbed {} {
+test winfo-13.2 {destroying embedded toplevel} -setup {
+ deleteWindows
+} -body {
frame .con -container 1
pack .con -expand yes -fill both
toplevel .emb -use [winfo id .con] -bd 0 -highlightthickness 0
button .emb.b
pack .emb.b -expand yes -fill both
update
-}
-test winfo-13.1 {root coordinates of embedded toplevel} {
- MakeEmbed
- set z [expr [winfo rootx .emb] == [winfo rootx .con] && \
- [winfo rooty .emb] == [winfo rooty .con]]
- destroy .emb
- destroy .con
- set z
-} {1}
-test winfo-13.2 {destroying embedded toplevel} {
+
destroy .emb
update
- expr [winfo exists .emb.b] || [winfo exists .con]
-} 0
+ list embedded [winfo exists .emb.b] container [winfo exists .con]
+} -cleanup {
+ deleteWindows
+} -result {embedded 0 container 1}
-deleteWindows
+test winfo-13.3 {destroying container window} -setup {
+ deleteWindows
+} -body {
+ frame .con -container 1
+ pack .con -expand yes -fill both
+ toplevel .emb -use [winfo id .con] -bd 0 -highlightthickness 0
+ button .emb.b
+ pack .emb.b -expand yes -fill both
+ update
-test winfo-13.3 {destroying container window} {
- MakeEmbed
destroy .con
update
- set z [expr [winfo exists .emb.b] || [winfo exists .emb]]
- catch {destroy .emb}
- catch {destroy .con}
- set z
-} 0
+ list child [winfo exists .emb.b] parent [winfo exists .emb]
+} -cleanup {
+ deleteWindows
+} -result {child 0 parent 0}
-deleteWindows
+test winfo-13.4 {[winfo containing] with embedded windows} -setup {
+ deleteWindows
+} -body {
+ frame .con -container 1
+ pack .con -expand yes -fill both
+ toplevel .emb -use [winfo id .con] -bd 0 -highlightthickness 0
+ button .emb.b
+ pack .emb.b -expand yes -fill both
+ update
-test winfo-13.4 {[winfo containing] with embedded windows} {
- MakeEmbed
button .b
pack .b -expand yes -fill both
update
+ string compare .emb.b \
+ [winfo containing [winfo rootx .emb.b] [winfo rooty .emb.b]]
+} -cleanup {
+ deleteWindows
+} -result 0
- set z [string compare \
- [winfo containing [winfo rootx .emb.b] [winfo rooty .emb.b]] .emb.b]
- catch {destroy .con}
- catch {destroy .emb}
- set z
-} 0
-test winfo-14.1 {usage} {
- list [catch {winfo ismapped} msg] $msg
-} {1 {wrong # args: should be "winfo ismapped window"}}
+test winfo-14.1 {usage} -body {
+ winfo ismapped
+} -returnCodes error -result {wrong # args: should be "winfo ismapped window"}
-test winfo-14.2 {usage} {
- list [catch {winfo ismapped . .} msg] $msg
-} {1 {wrong # args: should be "winfo ismapped window"}}
+test winfo-14.2 {usage} -body {
+ winfo ismapped . .
+} -returnCodes error -result {wrong # args: should be "winfo ismapped window"}
-test winfo-14.3 {initially unmapped} {
- catch {destroy .t}
+test winfo-14.3 {initially unmapped} -setup {
+ destroy .t
+} -body {
toplevel .t
winfo ismapped .t
-} 0
+} -cleanup {
+ destroy .t
+} -result 0
-test winfo-14.4 {mapped at idle time} {
- catch {destroy .t}
+test winfo-14.4 {mapped at idle time} -setup {
+ destroy .t
+} -body {
toplevel .t
update idletasks
winfo ismapped .t
-} 1
+} -cleanup {
+ destroy .t
+} -result 1
deleteWindows
# cleanup
cleanupTests
return
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tests/wm.test b/tests/wm.test
index 15526e7..1aa0779 100644
--- a/tests/wm.test
+++ b/tests/wm.test
@@ -641,16 +641,16 @@ test wm-geometry-1.3 {usage} -returnCodes error -body {
wm geometry . bogus
} -result {bad geometry specifier "bogus"}
-test wm-geometry-2.1 {setting values} -setup {
- set result {}
-} -body {
+test wm-geometry-2.1 {setting values} -body {
wm geometry .t 150x150+50+50
update
- lappend result [wm geometry .t]
+ set result [wm geometry .t]
wm geometry .t {}
update
- lappend result [string equal [wm geometry .t] "150x150+50+50"]
-} -result [list 150x150+50+50 0]
+ return [list $result [string equal [wm geometry .t] $result]]
+} -cleanup {
+ unset result
+} -match glob -result [list 150x150+*+* 0]
### wm grid ###
@@ -1354,6 +1354,7 @@ test wm-stackorder-2.3 {stacking order} -body {
toplevel .t ; update
toplevel .t2 ; update
raise .
+ raiseDelay
raise .t2
raiseDelay
wm stackorder .
@@ -1704,6 +1705,7 @@ test wm-transient-4.1 {transient toplevel is withdrawn
test wm-transient-4.2 {already mapped transient toplevel
is withdrawn if master is iconic} -body {
toplevel .master
+ raiseDelay
wm iconify .master
update
toplevel .subject
diff --git a/tests/xmfbox.test b/tests/xmfbox.test
index b60bf48..f50329c 100644
--- a/tests/xmfbox.test
+++ b/tests/xmfbox.test
@@ -1,4 +1,4 @@
-# xmfbox.test --
+# xmfbox.test --
#
# This file is a Tcl script to test the file dialog that's used
# when the tk_strictMotif flag is set. Because the file dialog
@@ -10,89 +10,104 @@
# Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
# All rights reserved.
-package require tcltest 2.1
-eval tcltest::configure $argv
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::configure {*}$argv
tcltest::loadTestedCommands
set testPWD [pwd]
-catch {unset foo}
-
catch {unset data foo}
proc cleanup {} {
global testPWD
set err0 [catch {
- cd $testPWD
+ cd $testPWD
} msg0]
set err1 [catch {
- if [file exists ./~nosuchuser1] {
- file delete ./~nosuchuser1
- }
+ if [file exists ./~nosuchuser1] {
+ file delete ./~nosuchuser1
+ }
} msg1]
set err2 [catch {
- if [file exists ./~nosuchuser2] {
- file delete ./~nosuchuser2
- }
+ if [file exists ./~nosuchuser2] {
+ file delete ./~nosuchuser2
+ }
} msg2]
set err3 [catch {
- if [file exists ./~nosuchuser3] {
- file delete ./~nosuchuser3
- }
+ if [file exists ./~nosuchuser3] {
+ file delete ./~nosuchuser3
+ }
} msg3]
set err4 [catch {
- if [file exists ./~nosuchuser4] {
- file delete ./~nosuchuser4
- }
+ if [file exists ./~nosuchuser4] {
+ file delete ./~nosuchuser4
+ }
} msg4]
if {$err0 || $err1 || $err2 || $err3 || $err4} {
- error [list $msg0 $msg1 $msg2 $msg3 $msg4]
+ error [list $msg0 $msg1 $msg2 $msg3 $msg4]
}
catch {unset foo}
- catch {destroy .foo}
+ destroy .foo
}
-test xmfbox-1.1 {tk::MotifFDialog_Create, -parent switch} unix {
+# ----------------------------------------------------------------------
+
+test xmfbox-1.1 {tk::MotifFDialog_Create, -parent switch} -constraints {
+ unix
+} -setup {
catch {unset foo}
+} -body {
set x [tk::MotifFDialog_Create foo open {-parent .}]
- catch {destroy $x}
- set x
-} .foo
+} -cleanup {
+ destroy $x
+} -result {.foo}
-test xmfbox-1.2 {tk::MotifFDialog_Create, -parent switch} unix {
+test xmfbox-1.2 {tk::MotifFDialog_Create, -parent switch} -constraints {
+ unix
+} -setup {
catch {unset foo}
+ deleteWindows
+} -body {
toplevel .bar
wm geometry .bar +0+0
set x [tk::MotifFDialog_Create foo open {-parent .bar}]
- catch {destroy $x}
- catch {destroy .bar}
- set x
-} .bar.foo
+} -cleanup {
+ destroy $x
+ destroy .bar
+} -result {.bar.foo}
-test xmfbox-2.1 {tk::MotifFDialog_InterpFilter, ~ in dir names} unix {
+
+test xmfbox-2.1 {tk::MotifFDialog_InterpFilter, ~ in dir names} -constraints {
+ unix
+} -body {
cleanup
file mkdir ./~nosuchuser1
set x [tk::MotifFDialog_Create foo open {}]
$::tk::dialog::file::foo(fEnt) delete 0 end
$::tk::dialog::file::foo(fEnt) insert 0 [pwd]/~nosuchuser1
set kk [tk::MotifFDialog_InterpFilter $x]
-} [list $testPWD/~nosuchuser1 *]
+} -result "$testPWD/~nosuchuser1 *"
-test xmfbox-2.2 {tk::MotifFDialog_InterpFilter, ~ in file names} unix {
+test xmfbox-2.2 {tk::MotifFDialog_InterpFilter, ~ in file names} -constraints {
+ unix
+} -body {
cleanup
close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}]
set x [tk::MotifFDialog_Create foo open {}]
$::tk::dialog::file::foo(fEnt) delete 0 end
$::tk::dialog::file::foo(fEnt) insert 0 [pwd]/~nosuchuser1
set kk [tk::MotifFDialog_InterpFilter $x]
-} [list $testPWD ./~nosuchuser1]
+} -result "$testPWD ./~nosuchuser1"
-test xmfbox-2.3 {tk::MotifFDialog_Update, ~ in file names} unix {
+test xmfbox-2.3 {tk::MotifFDialog_Update, ~ in file names} -constraints {
+ unix
+} -body {
cleanup
close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}]
set x [tk::MotifFDialog_Create foo open {}]
@@ -101,17 +116,21 @@ test xmfbox-2.3 {tk::MotifFDialog_Update, ~ in file names} unix {
tk::MotifFDialog_InterpFilter $x
tk::MotifFDialog_Update $x
$::tk::dialog::file::foo(fList) get end
-} ~nosuchuser1
+} -result {~nosuchuser1}
-test xmfbox-2.4 {tk::MotifFDialog_LoadFile, ~ in file names} unix {
+test xmfbox-2.4 {tk::MotifFDialog_LoadFile, ~ in file names} -constraints {
+ unix
+} -body {
cleanup
close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}]
set x [tk::MotifFDialog_Create foo open {}]
set i [lsearch [$::tk::dialog::file::foo(fList) get 0 end] ~nosuchuser1]
expr {$i >= 0}
-} 1
+} -result 1
-test xmfbox-2.5 {tk::MotifFDialog_BrowseFList, ~ in file names} unix {
+test xmfbox-2.5 {tk::MotifFDialog_BrowseFList, ~ in file names} -constraints {
+ unix
+} -body {
cleanup
close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}]
set x [tk::MotifFDialog_Create foo open {}]
@@ -120,9 +139,11 @@ test xmfbox-2.5 {tk::MotifFDialog_BrowseFList, ~ in file names} unix {
$::tk::dialog::file::foo(fList) selection set $i
tk::MotifFDialog_BrowseFList $x
$::tk::dialog::file::foo(sEnt) get
-} $testPWD/~nosuchuser1
+} -result "$testPWD/~nosuchuser1"
-test xmfbox-2.6 {tk::MotifFDialog_ActivateFList, ~ in file names} unix {
+test xmfbox-2.6 {tk::MotifFDialog_ActivateFList, ~ in file names} -constraints {
+ unix
+} -body {
cleanup
close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}]
set x [tk::MotifFDialog_Create foo open {}]
@@ -133,9 +154,13 @@ test xmfbox-2.6 {tk::MotifFDialog_ActivateFList, ~ in file names} unix {
tk::MotifFDialog_ActivateFList $x
list $::tk::dialog::file::foo(selectPath) \
$::tk::dialog::file::foo(selectFile) $tk::Priv(selectFilePath)
-} [list $testPWD ~nosuchuser1 $testPWD/~nosuchuser1]
+} -result "$testPWD ~nosuchuser1 $testPWD/~nosuchuser1"
# cleanup
cleanup
cleanupTests
return
+
+# Local variables:
+# mode: tcl
+# End: