summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authoraniap <aniap>2008-08-30 21:52:26 (GMT)
committeraniap <aniap>2008-08-30 21:52:26 (GMT)
commitefda61bdd67b9f540aa57722efec0e2430e6056f (patch)
tree2b09e17e0659d453eeaf5dfc31c2a205148b5e91
parent789cb9ff828c1e461866814e57d87a5c254b8c24 (diff)
downloadtk-efda61bdd67b9f540aa57722efec0e2430e6056f.zip
tk-efda61bdd67b9f540aa57722efec0e2430e6056f.tar.gz
tk-efda61bdd67b9f540aa57722efec0e2430e6056f.tar.bz2
Update to tcltest2
Diffstat
-rw-r--r--ChangeLog78
-rw-r--r--tests/textWind.test1190
-rw-r--r--tests/unixSelect.test414
-rw-r--r--tests/visual.test564
-rw-r--r--tests/visual_bb.test56
-rw-r--r--tests/winButton.test171
-rw-r--r--tests/winDialog.test447
-rw-r--r--tests/winFont.test456
-rw-r--r--tests/winMenu.test1259
-rw-r--r--tests/winMsgbox.test50
-rw-r--r--tests/winWm.test320
-rw-r--r--tests/window.test203
-rw-r--r--tests/winfo.test600
-rw-r--r--tests/xmfbox.test109
14 files changed, 3864 insertions, 2053 deletions
diff --git a/ChangeLog b/ChangeLog
index d6bac7e..9a6139c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,19 @@
+2008-08-30 Ania Pawelczyk <aniap@users.sourceforge.net>
+
+ * tests/textWind.test: Update to tcltest2
+ * tests/unixSelect.test:
+ * tests/visual_bb.test:
+ * tests/visual.test:
+ * tests/window.test:
+ * tests/winfo.test:
+ * tests/xmfbox.test:
+ * tests/winButton.test:
+ * tests/winDialog.test:
+ * tests/winFont.test:
+ * tests/winMenu.test:
+ * tests/winMsbox.test:
+ * tests/winWm.test:
+
2008-08-28 Don Porter <dgp@users.sourceforge.net>
* unix/tkConfig.sh.in: Added @XFT_LIBS@ to the definition of TK_LIBS
@@ -86,7 +102,7 @@
* tests/menuDraw.test: Update to tcltest2
* tests/msgbox.test:
* tests/oldpack.test:
- * tests/ pack.test:
+ * tests/pack.test:
* tests/panedwindow.test:
2008-08-21 Donal K. Fellows <dkf@users.sf.net>
@@ -168,9 +184,9 @@
2008-08-14 Ania Pawelczyk <aniap@users.sourceforge.net>
- * test/event.test: Update to tcltest2
- * test/id.test:
- * test/menu.test:
+ * tests/event.test: Update to tcltest2
+ * tests/id.test:
+ * tests/menu.test:
2008-08-14 Daniel Steffen <das@users.sourceforge.net>
@@ -181,10 +197,10 @@
2008-08-12 Ania Pawelczyk <aniap@users.sourceforge.net>
- * test/choosedir.test: Update to tcltest2
- * test/clipboard.test:
- * test/embed.test:
- * test/main.test:
+ * tests/choosedir.test: Update to tcltest2
+ * tests/clipboard.test:
+ * tests/embed.test:
+ * tests/main.test:
2008-08-12 Don Porter <dgp@users.sourceforge.net>
@@ -202,16 +218,16 @@
2008-08-11 Ania Pawelczyk <aniap@users.sourceforge.net>
- * test/canvImg.test: Update to tcltest2
- * test/canvRect.test:
- * test/canvText.test:
- * test/obj.test:
+ * tests/canvImg.test: Update to tcltest2
+ * tests/canvRect.test:
+ * tests/canvText.test:
+ * tests/obj.test:
2008-08-07 Ania Pawelczyk <aniap@users.sourceforge.net>
- * test/canvPs.test: Update to tcltest2
- * test/config.test:
- * test/canvas.test:
+ * tests/canvPs.test: Update to tcltest2
+ * tests/config.test:
+ * tests/canvas.test:
2008-08-05 Joe English <jenglish@users.sourceforge.net>
@@ -221,15 +237,15 @@
2008-08-03 Ania Pawelczyk <aniap@users.sourceforge.net>
- * test/cmds.test: Update to tcltest2
- * test/dialog.test:
- * test/get.test:
- * test/text.test: Update to tcltest2; report: 33.11 fails
+ * tests/cmds.test: Update to tcltest2
+ * tests/dialog.test:
+ * tests/get.test:
+ * tests/text.test: Update to tcltest2; report: 33.11 fails
2008-08-01 Pat Thoyts <patthoyts@users.sourceforge.net>
* win/tkWinWm.c: Check wmPtr is valid in TopLevelReqProc to fix
- * test/wm.test: [Bug 2028703]
+ * tests/wm.test: [Bug 2028703]
2008-07-31 Don Porter <dgp@users.sourceforge.net>
@@ -238,13 +254,13 @@
2008-07-29 Ania Pawelczyk <aniap@users.sourceforge.net>
- * test/constraints.tcl: -highlightthickness entry's option (fonts
+ * tests/constraints.tcl: -highlightthickness entry's option (fonts
constraint)
2008-07-28 Ania Pawelczyk <aniap@users.sourceforge.net>
- * test/cursor.test: Update to tcltest2
- * test/message.test:
+ * tests/cursor.test: Update to tcltest2
+ * tests/message.test:
2008-07-26 Pat Thoyts <patthoyts@users.sourceforge.net>
@@ -260,7 +276,7 @@
2008-07-25 Ania Pawelczyk <aniap@users.sourceforge.net>
- * test/bind.test: Update to tcltest2
+ * tests/bind.test: Update to tcltest2
2008-07-24 Jan Nijtmans <nijtmans@users.sf.net>
@@ -273,13 +289,13 @@
2008-07-22 Ania Pawelczyk <aniap@users.sourceforge.net>
- * test/bell.test: Update to tcltest2
- * test/bgerror.test:
- * test/bitmap.test:
- * test/border.test:
- * test/button.test:
- * test/entry.test:
- * test/spinbox.test:
+ * tests/bell.test: Update to tcltest2
+ * tests/bgerror.test:
+ * tests/bitmap.test:
+ * tests/border.test:
+ * tests/button.test:
+ * tests/entry.test:
+ * tests/spinbox.test:
2008-07-22 Daniel Steffen <das@users.sourceforge.net>
diff --git a/tests/textWind.test b/tests/textWind.test
index a0a0858..1cf0ecc 100644
--- a/tests/textWind.test
+++ b/tests/textWind.test
@@ -6,10 +6,11 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: textWind.test,v 1.23 2008/07/23 23:24:25 nijtmans Exp $
+# RCS: @(#) $Id: textWind.test,v 1.24 2008/08/30 21:52:26 aniap Exp $
-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
@@ -19,26 +20,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.
@@ -47,206 +43,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 ...?"}}
-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
@@ -254,89 +367,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
@@ -344,21 +511,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
@@ -366,9 +543,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
@@ -376,76 +559,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 {
@@ -455,68 +686,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
@@ -524,64 +803,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
@@ -589,11 +908,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
@@ -601,11 +925,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
@@ -615,10 +945,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
@@ -631,9 +969,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
@@ -647,11 +991,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
@@ -671,74 +1020,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"
@@ -746,11 +1135,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
@@ -762,11 +1155,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
@@ -778,10 +1174,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
@@ -790,9 +1190,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
@@ -801,27 +1205,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
@@ -829,11 +1244,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
@@ -844,21 +1263,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
@@ -866,13 +1290,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
@@ -881,12 +1307,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
@@ -897,10 +1323,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"
@@ -910,10 +1337,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"
@@ -922,14 +1351,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"
@@ -937,13 +1368,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"
@@ -951,14 +1383,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"
@@ -966,13 +1399,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"
@@ -980,14 +1414,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"
@@ -996,14 +1431,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"
@@ -1017,15 +1452,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/unixSelect.test b/tests/unixSelect.test
index 78decc4..08268b6 100644
--- a/tests/unixSelect.test
+++ b/tests/unixSelect.test
@@ -9,10 +9,11 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: unixSelect.test,v 1.10 2004/06/24 12:45:44 dkf Exp $
+# RCS: @(#) $Id: unixSelect.test,v 1.11 2008/08/30 21:52:26 aniap Exp $
-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
@@ -25,7 +26,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]
}
@@ -33,18 +34,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]
}
@@ -59,23 +60,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]
}
@@ -91,10 +92,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
}
@@ -106,255 +107,358 @@ 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 selection range 0 end
- set result [dobg {string bytelength [selection get]}]
+ dobg {string bytelength [selection get]}
+} -cleanup {
cleanupbg
destroy .e
- set result
-} {5}
-test unixSelect-1.2 {TkSelGetSelection procedure: simple i18n text, iso8859-1} unix {
+} -result {5}
+
+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]
- 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 {
+ [string length $x] [string bytelength $x]
+} -cleanup {
+ cleanupbg
+} -result {1 2 3}
+
+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] [string bytelength $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 4 {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] [string bytelength $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 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.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] [string bytelength $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 4 {COMPOUND_TEXT 0 4000}}
+
+test unixSelect-1.6 {TkSelGetSelection procedure: INCR i18n text} -constraints {
+ unix
+} -setup {
setupbg
+} -body {
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]]
+ string bytelength [selection get]
+} -cleanup {
cleanupbg
- set result
-} [expr {5 + [string bytelength $longValue]}]
-test unixSelect-1.8 {TkSelGetSelection procedure: INCR i18n text} unix {
+} -result [expr {5 + [string bytelength $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]
- 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 {
+ [string length $x] [string bytelength $x]
+} -cleanup {
+ cleanupbg
+} -result {1 4000 4001}
+
+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]
- 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 {
+ [string length $x] [string bytelength $x]
+} -cleanup {
+ cleanupbg
+} -result {1 4000 4001}
+
+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]
- cleanupbg
list [string equal [string repeat x 3999]\u00fc[string repeat x 4000] $x] \
- [string length $x] [string bytelength $x]
-} {1 8000 8001}
+ [string length $x] [string bytelength $x]
+} -cleanup {
+ cleanupbg
+} -result {1 8000 8001}
# 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]
- 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 {
+ [string length $x] [string bytelength $x]
+} -cleanup {
+ cleanupbg
+} -result {1 4000 4001}
+
+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]
- 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 {
+ [string length $x] [string bytelength $x]
+} -cleanup {
+ cleanupbg
+} -result {1 4000 4001}
+
+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]
- 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 {
+ [string length $x] [string bytelength $x]
+} -cleanup {
+ cleanupbg
+} -result {1 8000 8001}
+
+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 selection range 0 end
- set result [dobg {string bytelength [selection get -type UTF8_STRING]}]
- cleanupbg
+ dobg {string bytelength [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]
- 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 {
+ [string length $x] [string bytelength $x]
+} -cleanup {
+ cleanupbg
+} -result {1 2 4}
+
+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]
- 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 {
+ [string length $x] [string bytelength $x]
+} -cleanup {
+ cleanupbg
+} -result {1 2121 4221}
+
+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]
- 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 {
+ [string length $x] [string bytelength $x]
+} -cleanup {
+ cleanupbg
+} -result {1 2122 4222}
+
+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]
- 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 {
+ [string length $x] [string bytelength $x]
+} -cleanup {
+ cleanupbg
+} -result {1 2121 4221}
+
+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]
- 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 {
+ [string length $x] [string bytelength $x]
+} -cleanup {
+ cleanupbg
+} -result {1 2122 4222}
+
+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/visual.test b/tests/visual.test
index b54a8e6..61f5001 100644
--- a/tests/visual.test
+++ b/tests/visual.test
@@ -7,10 +7,11 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: visual.test,v 1.10 2004/06/17 22:38:57 dkf Exp $
+# RCS: @(#) $Id: visual.test,v 1.11 2008/08/30 21:52:26 aniap Exp $
-package require tcltest 2.1
-eval tcltest::configure $argv
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::configure {*}$argv
tcltest::loadTestedCommands
update
@@ -20,7 +21,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}
@@ -29,12 +30,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
}
@@ -45,14 +46,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
@@ -63,233 +64,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 {}
@@ -298,3 +566,7 @@ rename colorsFree {}
# cleanup
cleanupTests
return
+
+# Local variables:
+# mode: tcl
+# End: \ No newline at end of file
diff --git a/tests/visual_bb.test b/tests/visual_bb.test
index a465d64..729a3fe 100644
--- a/tests/visual_bb.test
+++ b/tests/visual_bb.test
@@ -6,12 +6,14 @@
# at the window to make sure it appears as expected. Individual tests
# are kept in separate ".tcl" files in this directory.
#
-# RCS: @(#) $Id: visual_bb.test,v 1.8 2003/04/01 21:07:00 dgp Exp $
+# RCS: @(#) $Id: visual_bb.test,v 1.9 2008/08/30 21:52:26 aniap Exp $
-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"
@@ -23,8 +25,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
}
@@ -40,7 +42,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
@@ -49,8 +53,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
@@ -62,40 +66,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
@@ -105,7 +109,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 1ffcc2f..a383433 100644
--- a/tests/winButton.test
+++ b/tests/winButton.test
@@ -8,79 +8,93 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: winButton.test,v 1.12 2007/05/11 12:10:19 patthoyts Exp $
+# RCS: @(#) $Id: winButton.test,v 1.13 2008/08/30 21:52:26 aniap Exp $
-package require tcltest 2.1
-eval tcltest::configure $argv
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::configure {*}$argv
tcltest::loadTestedCommands
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}
@@ -88,26 +102,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
@@ -115,33 +149,50 @@ 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
deleteWindows
cleanupTests
return
+
+# Local variables:
+# mode: tcl
+# End:
+
diff --git a/tests/winDialog.test b/tests/winDialog.test
index 219255b..c2c7b35 100644
--- a/tests/winDialog.test
+++ b/tests/winDialog.test
@@ -7,10 +7,11 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 1998-1999 ActiveState Corporation.
#
-# RCS: @(#) $Id: winDialog.test,v 1.17 2008/05/13 12:39:28 patthoyts Exp $
+# RCS: @(#) $Id: winDialog.test,v 1.18 2008/08/30 21:52:26 aniap Exp $
-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]} {
@@ -35,12 +36,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]}
}
@@ -58,7 +59,9 @@ proc SetText {button text} {
return [testwinevent $::tk_dialog $button WM_SETTEXT $text]
}
-test winDialog-1.1.0 {Tk_ChooseColorObjCmd} -constraints {
+# ----------------------------------------------------------------------
+
+test winDialog-1.1 {Tk_ChooseColorObjCmd} -constraints {
testwinevent
} -body {
start {tk_chooseColor}
@@ -66,7 +69,7 @@ test winDialog-1.1.0 {Tk_ChooseColorObjCmd} -constraints {
Click cancel
}
} -result {0}
-test winDialog-1.1.1 {Tk_ChooseColorObjCmd} -constraints {
+test winDialog-1.2 {Tk_ChooseColorObjCmd} -constraints {
testwinevent
} -body {
start {set clr [tk_chooseColor -initialcolor "#ff9933"]}
@@ -75,7 +78,7 @@ test winDialog-1.1.1 {Tk_ChooseColorObjCmd} -constraints {
}
list $x $clr
} -result {0 {}}
-test winDialog-1.1.2 {Tk_ChooseColorObjCmd} -constraints {
+test winDialog-1.3 {Tk_ChooseColorObjCmd} -constraints {
testwinevent
} -body {
start {set clr [tk_chooseColor -initialcolor "#ff9933"]}
@@ -84,9 +87,11 @@ test winDialog-1.1.2 {Tk_ChooseColorObjCmd} -constraints {
}
list $x $clr
} -result [list 0 "#ff9933"]
-test winDialog-1.1.3 {Tk_ChooseColorObjCmd: -title} -constraints {
+test winDialog-1.4 {Tk_ChooseColorObjCmd: -title} -constraints {
testwinevent
-} -setup {unset a x} -body {
+} -setup {
+ catch {unset a x}
+} -body {
set x {}
start {set clr [tk_chooseColor -initialcolor "#ff9933" -title "Hello"]}
then {
@@ -98,9 +103,11 @@ test winDialog-1.1.3 {Tk_ChooseColorObjCmd: -title} -constraints {
}
lappend x $clr
} -result [list Hello 0 "#ff9933"]
-test winDialog-1.1.4 {Tk_ChooseColorObjCmd: -title} -constraints {
+test winDialog-1.5 {Tk_ChooseColorObjCmd: -title} -constraints {
testwinevent
-} -setup {unset a x} -body {
+} -setup {
+ catch {unset a x}
+} -body {
set x {}
start {
set clr [tk_chooseColor -initialcolor "#ff9933" \
@@ -115,9 +122,11 @@ test winDialog-1.1.4 {Tk_ChooseColorObjCmd: -title} -constraints {
}
lappend x $clr
} -result [list "\u041f\u0440\u0438\u0432\u0435\u0442" 0 "#ff9933"]
-test winDialog-1.1.5 {Tk_ChooseColorObjCmd: -parent} -constraints {
+test winDialog-1.6 {Tk_ChooseColorObjCmd: -parent} -constraints {
testwinevent
-} -setup {unset a x} -body {
+} -setup {
+ catch {unset a x}
+} -body {
start {set clr [tk_chooseColor -initialcolor "#ff9933" -parent .]}
set x {}
then {
@@ -131,285 +140,360 @@ test winDialog-1.1.5 {Tk_ChooseColorObjCmd: -parent} -constraints {
}
list $x $clr
} -result [list 1 "#ff9933"]
-test winDialog-1.1.6 {Tk_ChooseColorObjCmd: -parent} -constraints {
+test winDialog-1.7 {Tk_ChooseColorObjCmd: -parent} -constraints {
testwinevent
} -body {
tk_chooseColor -initialcolor "#ff9933" -parent .xyzzy12
} -returnCodes error -match glob -result {bad window path name*}
-test winDialog-2.1 {ColorDlgHookProc} {emptyTest nt} {
-} {}
-test winDialog-3.1 {Tk_GetOpenFileObjCmd} {nt testwinevent} {
+test winDialog-2.1 {ColorDlgHookProc} -constraints {emptyTest nt} -body {}
+
+
+test winDialog-3.1 {Tk_GetOpenFileObjCmd} -constraints {
+ nt testwinevent
+} -body {
start {tk_getOpenFile}
then {
- set x [GetText 2]
- Click 2
+ set x [GetText 2]
+ Click 2
}
- set x
-} {Cancel}
+ return $x
+} -result {Cancel}
-test winDialog-4.1 {Tk_GetSaveFileObjCmd} {nt testwinevent} {
+
+test winDialog-4.1 {Tk_GetSaveFileObjCmd} -constraints {
+ nt testwinevent
+} -body {
start {tk_getSaveFile}
then {
- set x [GetText 2]
- Click 2
+ set x [GetText 2]
+ Click 2
}
- set x
-} {Cancel}
+ return $x
+} -result {Cancel}
-test winDialog-5.1 {GetFileName: no arguments} {nt testwinevent} {
+test winDialog-5.1 {GetFileName: no arguments} -constraints {
+ nt testwinevent
+} -body {
start {tk_getOpenFile -title Open}
then {
- Click cancel
+ Click cancel
}
-} {0}
-test winDialog-5.2 {GetFileName: one argument} {nt} {
- list [catch {tk_getOpenFile -foo} msg] $msg
-} {1 {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable}}
-test winDialog-5.4 {GetFileName: many arguments} {nt testwinevent} {
+} -result {0}
+test winDialog-5.2 {GetFileName: one argument} -constraints {
+ nt
+} -body {
+ tk_getOpenFile -foo
+} -returnCodes error -result {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable}
+test winDialog-5.3 {GetFileName: many arguments} -constraints {
+ nt testwinevent
+} -body {
start {tk_getOpenFile -initialdir c:/ -parent . -title test -initialfile foo}
then {
- Click cancel
+ Click cancel
}
-} {0}
-test winDialog-5.5 {GetFileName: Tcl_GetIndexFromObj() != TCL_OK} {nt} {
- list [catch {tk_getOpenFile -foo bar -abc} msg] $msg
-} {1 {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable}}
-test winDialog-5.6 {GetFileName: Tcl_GetIndexFromObj() == TCL_OK} {nt testwinevent} {
+} -result {0}
+test winDialog-5.4 {GetFileName: Tcl_GetIndexFromObj() != TCL_OK} -constraints {
+ nt
+} -body {
+ tk_getOpenFile -foo bar -abc
+} -returnCodes error -result {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable}
+test winDialog-5.5 {GetFileName: Tcl_GetIndexFromObj() == TCL_OK} -constraints {
+ nt testwinevent
+} -body {
start {tk_getOpenFile -title bar}
then {
- Click cancel
+ Click cancel
}
-} {0}
-test winDialog-5.7 {GetFileName: valid option, but missing value} {nt} {
- list [catch {tk_getOpenFile -initialdir bar -title} msg] $msg
-} {1 {value for "-title" missing}}
-test winDialog-5.8 {GetFileName: extension begins with .} {nt testwinevent} {
+} -result {0}
+test winDialog-5.6 {GetFileName: valid option, but missing value} -constraints {
+ nt
+} -body {
+ tk_getOpenFile -initialdir bar -title
+} -returnCodes error -result {value for "-title" missing}
+test winDialog-5.7 {GetFileName: extension begins with .} -constraints {
+ nt testwinevent
+} -body {
# if (string[0] == '.') {
-# string++;
+# string++;
# }
start {set x [tk_getSaveFile -defaultextension .foo -title Save]}
then {
- SetText 0x480 bar
- Click 1
+ SetText 0x480 bar
+ Click 1
}
string totitle $x
-} [string totitle [file join [pwd] bar.foo]]
-test winDialog-5.9 {GetFileName: extension doesn't begin with .} {nt testwinevent} {
+} -result [string totitle [file join [pwd] bar.foo]]
+test winDialog-5.8 {GetFileName: extension doesn't begin with .} -constraints {
+ nt testwinevent
+} -body {
start {set x [tk_getSaveFile -defaultextension foo -title Save]}
then {
- SetText 0x480 bar
- Click 1
+ SetText 0x480 bar
+ Click 1
}
string totitle $x
-} [string totitle [file join [pwd] bar.foo]]
-test winDialog-5.10 {GetFileName: file types} {nt testwinevent} {
-# case FILE_TYPES:
+} -result [string totitle [file join [pwd] bar.foo]]
+test winDialog-5.9 {GetFileName: file types} -constraints {
+ nt testwinevent
+} -body {
+# case FILE_TYPES:
start {tk_getSaveFile -filetypes {{"foo files" .foo FOOF}} -title Foo}
then {
- set x [GetText 0x470]
- Click cancel
+ set x [GetText 0x470]
+ Click cancel
}
- set x
-} {foo files (*.foo)}
-test winDialog-5.11 {GetFileName: file types: MakeFilter() fails} {nt} {
-# if (MakeFilter(interp, string, &utfFilterString) != TCL_OK)
+ return $x
+} -result {foo files (*.foo)}
+test winDialog-5.10 {GetFileName: file types: MakeFilter() fails} -constraints {
+ nt
+} -body {
+# if (MakeFilter(interp, string, &utfFilterString) != TCL_OK)
- list [catch {tk_getSaveFile -filetypes {{"foo" .foo FOO}}} msg] $msg
-} {1 {bad Macintosh file type "FOO"}}
-test winDialog-5.12 {GetFileName: initial directory} {nt testwinevent} {
-# case FILE_INITDIR:
+ tk_getSaveFile -filetypes {{"foo" .foo FOO}}
+} -returnCodes error -result {bad Macintosh file type "FOO"}
+test winDialog-5.11 {GetFileName: initial directory} -constraints {
+ nt testwinevent
+} -body {
+# case FILE_INITDIR:
start {set x [tk_getSaveFile -initialdir c:/ -initialfile "12x 455" -title Foo]}
then {
- Click 1
- }
- set x
-} {C:/12x 455}
-test winDialog-5.13 {GetFileName: initial directory: Tcl_TranslateFilename()} \
- {nt} {
-# if (Tcl_TranslateFileName(interp, string, &ds) == NULL)
-
- list [catch {tk_getOpenFile -initialdir ~12x/455} msg] $msg
-} {1 {user "12x" doesn't exist}}
-test winDialog-5.14 {GetFileName: initial file} {nt testwinevent} {
-# case FILE_INITFILE:
+ Click 1
+ }
+ return $x
+} -result {C:/12x 455}
+test winDialog-5.12 {GetFileName: initial directory: Tcl_TranslateFilename()} -constraints {
+ nt
+} -body {
+# if (Tcl_TranslateFileName(interp, string, &ds) == NULL)
+
+ tk_getOpenFile -initialdir ~12x/455
+} -returnCodes error -result {user "12x" doesn't exist}
+test winDialog-5.13 {GetFileName: initial file} -constraints {
+ nt testwinevent
+} -body {
+# case FILE_INITFILE:
start {set x [tk_getSaveFile -initialfile "12x 456" -title Foo]}
then {
- Click 1
+ Click 1
}
string totitle $x
-} [string totitle [file join [pwd] "12x 456"]]
-test winDialog-5.15 {GetFileName: initial file: Tcl_TranslateFileName()} {nt} {
-# if (Tcl_TranslateFileName(interp, string, &ds) == NULL)
- list [catch {tk_getOpenFile -initialfile ~12x/455} msg] $msg
-} {1 {user "12x" doesn't exist}}
-test winDialog-5.16 {GetFileName: initial file: long name} {nt testwinevent} {
+} -result [string totitle [file join [pwd] "12x 456"]]
+test winDialog-5.14 {GetFileName: initial file: Tcl_TranslateFileName()} -constraints {
+ nt
+} -body {
+# if (Tcl_TranslateFileName(interp, string, &ds) == NULL)
+ tk_getOpenFile -initialfile ~12x/455
+} -returnCodes error -result {user "12x" doesn't exist}
+test winDialog-5.15 {GetFileName: initial file: long name} -constraints {
+ nt testwinevent
+} -body {
start {
set dialogresult [catch {
tk_getSaveFile -initialfile [string repeat a 1024] -title Long
} x]
}
then {
- Click 1
+ Click 1
}
list $dialogresult [string match "invalid filename *" $x]
-} {1 1}
-test winDialog-5.17 {GetFileName: parent} {nt} {
-# case FILE_PARENT:
+} -result {1 1}
+test winDialog-5.16 {GetFileName: parent} -constraints {
+ nt
+} -body {
+# case FILE_PARENT:
toplevel .t
set x 0
start {tk_getOpenFile -parent .t -title Parent; set x 1}
then {
- destroy .t
+ destroy .t
}
- set x
-} {1}
-test winDialog-5.18 {GetFileName: title} {nt testwinevent} {
-# case FILE_TITLE:
-
+ return $x
+} -result {1}
+test winDialog-5.17 {GetFileName: title} -constraints {
+ nt testwinevent
+} -body {
+# case FILE_TITLE:
+
start {tk_getOpenFile -title Narf}
then {
- Click 2
+ Click 2
}
-} {0}
-test winDialog-5.19 {GetFileName: no filter specified} {nt testwinevent} {
-# if (ofn.lpstrFilter == NULL)
+} -result {0}
+test winDialog-5.18 {GetFileName: no filter specified} -constraints {
+ nt testwinevent
+} -body {
+# if (ofn.lpstrFilter == NULL)
- start {tk_getOpenFile -title Filter}
+ start {tk_getOpenFile -title Filter}
then {
- set x [GetText 0x470]
- Click 2
- }
- set x
-} {All Files (*.*)}
-test winDialog-5.20 {GetFileName: parent HWND doesn't yet exist} {nt} {
-# if (Tk_WindowId(parent) == None)
+ set x [GetText 0x470]
+ Click 2
+ }
+ return $x
+} -result {All Files (*.*)}
+test winDialog-5.19 {GetFileName: parent HWND doesn't yet exist} -constraints {
+ nt
+} -setup {
+ destroy .t
+} -body {
+# if (Tk_WindowId(parent) == None)
toplevel .t
start {tk_getOpenFile -parent .t -title Open}
then {
- destroy .t
+ destroy .t
}
-} {}
-test winDialog-5.21 {GetFileName: parent HWND already exists} {nt} {
+} -result {}
+test winDialog-5.20 {GetFileName: parent HWND already exists} -constraints {
+ nt
+} -setup {
+ destroy .t
+} -body {
toplevel .t
update
start {tk_getOpenFile -parent .t -title Open}
then {
- destroy .t
+ destroy .t
}
-} {}
-test winDialog-5.22 {GetFileName: call GetOpenFileName} {nt testwinevent} {
-# winCode = GetOpenFileName(&ofn);
-
+} -result {}
+test winDialog-5.21 {GetFileName: call GetOpenFileName} -constraints {
+ nt testwinevent
+} -body {
+# winCode = GetOpenFileName(&ofn);
+
start {tk_getOpenFile -title Open}
then {
- set x [GetText 1]
- Click 2
+ set x [GetText 1]
+ Click 2
}
- set x
-} {&Open}
-test winDialog-5.23 {GetFileName: call GetSaveFileName} {nt testwinevent} {
-# winCode = GetSaveFileName(&ofn);
+ return $x
+} -result {&Open}
+test winDialog-5.22 {GetFileName: call GetSaveFileName} -constraints {
+ nt testwinevent
+} -body {
+# winCode = GetSaveFileName(&ofn);
start {tk_getSaveFile -title Save}
then {
- set x [GetText 1]
- Click 2
+ set x [GetText 1]
+ Click 2
}
- set x
-} {&Save}
-test winDialog-5.24 {GetFileName: convert \ to /} {nt testwinevent} {
+ return $x
+} -result {&Save}
+test winDialog-5.23 {GetFileName: convert \ to /} -constraints {
+ nt testwinevent
+} -body {
start {set x [tk_getSaveFile -title Back]}
then {
- SetText 0x480 "c:\\12x 457"
- Click 1
+ SetText 0x480 "c:\\12x 457"
+ Click 1
}
- set x
-} {c:/12x 457}
-test winDialog-5.25 {GetFileName: file types: MakeFilter() succeeds} {nt} {
+ return $x
+} -result {c:/12x 457}
+test winDialog-5.24 {GetFileName: file types: MakeFilter() succeeds} -constraints {
+ nt
+} -body {
# MacOS type that is correct, but has embedded nulls.
start {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0\0\0}}}}]}
then {
- Click 2
+ Click 2
}
- set x
-} {0}
-test winDialog-5.26 {GetFileName: file types: MakeFilter() succeeds} {nt} {
+ return $x
+} -result {0}
+test winDialog-5.25 {GetFileName: file types: MakeFilter() succeeds} -constraints {
+ nt
+} -body {
# MacOS type that is correct, but has embedded high-bit chars.
start {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\u2022\u2022\u2022\u2022}}}}]}
then {
- Click 2
+ Click 2
}
- set x
-} {0}
+ return $x
+} -result {0}
+
+
+test winDialog-6.1 {MakeFilter} -constraints {emptyTest nt} -body {}
+
-test winDialog-6.1 {MakeFilter} {emptyTest nt} {} {}
+test winDialog-7.1 {Tk_MessageBoxObjCmd} -constraints {emptyTest nt} -body {}
-test winDialog-7.1 {Tk_MessageBoxObjCmd} {emptyTest nt} {} {}
-test winDialog-8.1 {OFNHookProc} {emptyTest nt} {} {}
+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.
##
-test winDialog-9.1 {Tk_ChooseDirectoryObjCmd: no arguments} {nt testwinevent} {
+test winDialog-9.1 {Tk_ChooseDirectoryObjCmd: no arguments} -constraints {
+ nt testwinevent
+} -body {
start {tk_chooseDirectory}
then {
- Click cancel
+ Click cancel
}
-} {0}
-test winDialog-9.2 {Tk_ChooseDirectoryObjCmd: one argument} {nt} {
- list [catch {tk_chooseDirectory -foo} msg] $msg
-} {1 {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title}}
-test winDialog-9.3 {Tk_ChooseDirectoryObjCmd: many arguments} {nt testwinevent} {
+} -result {0}
+test winDialog-9.2 {Tk_ChooseDirectoryObjCmd: one argument} -constraints {
+ nt
+} -body {
+ tk_chooseDirectory -foo
+} -returnCodes error -result {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title}
+test winDialog-9.3 {Tk_ChooseDirectoryObjCmd: many arguments} -constraints {
+ nt testwinevent
+} -body {
start {
- tk_chooseDirectory -initialdir c:/ -mustexist 1 -parent . -title test
+ tk_chooseDirectory -initialdir c:/ -mustexist 1 -parent . -title test
}
then {
- Click cancel
- }
-} {0}
-test winDialog-9.4 {Tk_ChooseDirectoryObjCmd:\
- Tcl_GetIndexFromObj() != TCL_OK} {nt} {
- list [catch {tk_chooseDirectory -foo bar -abc} msg] $msg
-} {1 {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title}}
-test winDialog-9.5 {Tk_ChooseDirectoryObjCmd:\
- Tcl_GetIndexFromObj() == TCL_OK} {nt testwinevent} {
+ Click cancel
+ }
+} -result {0}
+test winDialog-9.4 {Tk_ChooseDirectoryObjCmd: Tcl_GetIndexFromObj() != TCL_OK} -constraints {
+ nt
+} -body {
+ tk_chooseDirectory -foo bar -abc
+} -returnCodes error -result {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title}
+test winDialog-9.5 {Tk_ChooseDirectoryObjCmd: Tcl_GetIndexFromObj() == TCL_OK} -constraints {
+ nt testwinevent
+} -body {
start {tk_chooseDirectory -title bar}
then {
- Click cancel
+ Click cancel
}
-} {0}
-test winDialog-9.6 {Tk_ChooseDirectoryObjCmd:\
- valid option, but missing value} {nt} {
- list [catch {tk_chooseDirectory -initialdir bar -title} msg] $msg
-} {1 {value for "-title" missing}}
-test winDialog-9.7 {Tk_ChooseDirectoryObjCmd: -initialdir} {nt testwinevent} {
-# case DIR_INITIAL:
+} -result {0}
+test winDialog-9.6 {Tk_ChooseDirectoryObjCmd: valid option, but missing value} -constraints {
+ nt
+} -body {
+ tk_chooseDirectory -initialdir bar -title
+} -returnCodes error -result {value for "-title" missing}
+test winDialog-9.7 {Tk_ChooseDirectoryObjCmd: -initialdir} -constraints {
+ nt testwinevent
+} -body {
+# case DIR_INITIAL:
start {set x [tk_chooseDirectory -initialdir c:/ -title Foo]}
then {
- Click 1
+ Click 1
}
string tolower [set x]
-} {c:/}
-test winDialog-9.8 {Tk_ChooseDirectoryObjCmd:\
- initial directory: Tcl_TranslateFilename()} {nt} {
-# if (Tcl_TranslateFileName(interp, string,
-# &utfDirString) == NULL)
-
- list [catch {tk_chooseDirectory -initialdir ~12x/455} msg] $msg
-} {1 {user "12x" doesn't exist}}
+} -result {c:/}
+test winDialog-9.8 {Tk_ChooseDirectoryObjCmd: initial directory: Tcl_TranslateFilename()} -constraints {
+ nt
+} -body {
+# if (Tcl_TranslateFileName(interp, string,
+# &utfDirString) == NULL)
+
+ tk_chooseDirectory -initialdir ~12x/455
+} -returnCodes error -result {user "12x" doesn't exist}
if {[testConstraint testwinevent]} {
catch {testwinevent debug 0}
@@ -418,3 +502,8 @@ if {[testConstraint testwinevent]} {
# cleanup
cleanupTests
return
+
+# Local variables:
+# mode: tcl
+# End:
+
diff --git a/tests/winFont.test b/tests/winFont.test
index 82d0c36..4491de0 100644
--- a/tests/winFont.test
+++ b/tests/winFont.test
@@ -1,50 +1,30 @@
-# 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.
#
-# RCS: @(#) $Id: winFont.test,v 1.11 2004/12/04 00:04:43 dkf Exp $
+# RCS: @(#) $Id: winFont.test,v 1.12 2008/08/30 21:52:26 aniap Exp $
-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
@@ -52,135 +32,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 ff3296b..813d4c5 100644
--- a/tests/winMenu.test
+++ b/tests/winMenu.test
@@ -7,142 +7,185 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: winMenu.test,v 1.10 2007/05/09 12:52:44 das Exp $
+# RCS: @(#) $Id: winMenu.test,v 1.11 2008/08/30 21:52:26 aniap Exp $
-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
@@ -150,103 +193,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
@@ -254,17 +334,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
@@ -272,521 +358,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
@@ -794,160 +1076,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
@@ -955,11 +1288,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
@@ -967,31 +1302,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
@@ -999,19 +1345,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
@@ -1020,11 +1369,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 85fd44d..e0dab81 100644
--- a/tests/winMsgbox.test
+++ b/tests/winMsgbox.test
@@ -2,10 +2,11 @@
#
# Copyright (c) 2007 Pat Thoyts <patthoyts@users.sourceforge.net>
#
-# RCS: @(#) $Id: winMsgbox.test,v 1.2 2007/12/13 15:27:55 dgp Exp $
+# RCS: @(#) $Id: winMsgbox.test,v 1.3 2008/08/30 21:52:26 aniap Exp $
-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}]
@@ -40,7 +41,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
@@ -51,7 +52,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
@@ -62,7 +63,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
@@ -73,7 +74,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
@@ -84,7 +85,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
@@ -95,7 +96,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
@@ -106,7 +107,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
@@ -117,7 +118,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
@@ -128,7 +129,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
@@ -139,7 +140,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
@@ -150,7 +151,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
@@ -161,7 +162,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
@@ -172,7 +173,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
@@ -185,7 +186,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 {
@@ -200,7 +201,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 .
@@ -217,7 +218,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 .
@@ -234,7 +235,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 .
@@ -250,7 +251,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 .
@@ -267,7 +270,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 .
@@ -296,4 +299,5 @@ return
# Local variables:
# mode: tcl
# indent-tabs-mode: nil
-# End: \ No newline at end of file
+# End:
+
diff --git a/tests/winWm.test b/tests/winWm.test
index 13ab984..5267b28 100644
--- a/tests/winWm.test
+++ b/tests/winWm.test
@@ -9,39 +9,28 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: winWm.test,v 1.19 2008/07/23 23:24:24 nijtmans Exp $
+# RCS: @(#) $Id: winWm.test,v 1.20 2008/08/30 21:52:26 aniap Exp $
-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
@@ -49,40 +38,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
@@ -93,10 +89,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
@@ -108,12 +106,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
@@ -125,13 +125,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
@@ -145,11 +147,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
@@ -163,13 +170,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
@@ -180,18 +204,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
@@ -206,11 +233,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
@@ -228,29 +256,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
@@ -260,72 +300,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
@@ -333,9 +395,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
@@ -344,10 +410,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
@@ -355,23 +424,34 @@ 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? image ?image ...?"}}
-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? image ?image ...?"}
+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 {}
destroy .t
# cleanup
cleanupTests
return
+
+# Local variables:
+# mode: tcl
+# End:
+
diff --git a/tests/window.test b/tests/window.test
index 6d5d9aa..e5b10f6 100644
--- a/tests/window.test
+++ b/tests/window.test
@@ -5,42 +5,51 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: window.test,v 1.12 2004/06/24 12:45:44 dkf Exp $
+# RCS: @(#) $Id: window.test,v 1.13 2008/08/30 21:52:26 aniap Exp $
-package require tcltest 2.1
-eval tcltest::configure $argv
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::configure {*}$argv
tcltest::loadTestedCommands
+namespace import ::tk::test::loadTkCommand
-namespace import -force ::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,16 +184,17 @@ test window-2.8 {Tk_DestroyWindow, cleanup half dead windows at exit} \
}
set script [makeFile $code script]
if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
- set error 1
+ set error 1
} else {
- set error 0
+ set error 0
}
removeFile script
list $error $msg
-} {0 {}}
+} -result {0 {}}
-test window-2.9 {Tk_DestroyWindow, Destroy bindings
- evaluated after exit} unixOrWin {
+test window-2.9 {Tk_DestroyWindow, Destroy bindings evaluated after exit} -constraints {
+ unixOrWin
+} -body {
set code [loadTkCommand]
append code {
toplevel .t1
@@ -187,17 +206,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
@@ -210,16 +230,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
@@ -237,17 +258,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]
@@ -255,10 +279,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]
@@ -269,23 +297,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]
@@ -296,8 +340,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: \ No newline at end of file
diff --git a/tests/winfo.test b/tests/winfo.test
index 0b2b9d6..6754ca3 100644
--- a/tests/winfo.test
+++ b/tests/winfo.test
@@ -6,10 +6,11 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: winfo.test,v 1.15 2007/12/13 15:27:55 dgp Exp $
+# RCS: @(#) $Id: winfo.test,v 1.16 2008/08/30 21:52:26 aniap Exp $
-package require tcltest 2.1
-eval tcltest::configure $argv
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::configure {*}$argv
tcltest::loadTestedCommands
# eatColors --
@@ -17,22 +18,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
}
@@ -40,57 +41,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
@@ -101,69 +114,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
@@ -171,78 +218,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
@@ -250,121 +332,155 @@ 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} -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-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-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
-proc MakeEmbed {} {
+ expr {[winfo rootx .emb] == [winfo rootx .con] \
+ && [winfo rooty .emb] == [winfo rooty .con]}
+} -cleanup {
+ deleteWindows
+} -result {1}
+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
+ expr {[winfo exists .emb.b] || [winfo exists .con]}
+} -cleanup {
+ deleteWindows
+} -result 0
-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
+ expr {[winfo exists .emb.b] || [winfo exists .emb]}
+} -cleanup {
+ deleteWindows
+} -result 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: \ No newline at end of file
diff --git a/tests/xmfbox.test b/tests/xmfbox.test
index 7f6c3fe..896599f 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,91 +10,106 @@
# Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
# All rights reserved.
#
-# RCS: @(#) $Id: xmfbox.test,v 1.10 2004/06/24 12:45:45 dkf Exp $
+# RCS: @(#) $Id: xmfbox.test,v 1.11 2008/08/30 21:52:26 aniap Exp $
-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 {}]
@@ -103,17 +118,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 {}]
@@ -122,9 +141,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 {}]
@@ -135,9 +156,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: \ No newline at end of file
generated by cgit v0.12 at 2024-11-09 23:48:00 (GMT)