summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/option.test505
-rw-r--r--tests/place.test437
-rw-r--r--tests/scale.test1498
-rw-r--r--tests/select.test595
-rw-r--r--tests/textBTree.test1089
-rw-r--r--tests/textImage.test690
-rw-r--r--tests/textMark.test347
-rw-r--r--tests/textTag.test1663
-rw-r--r--tests/unixMenu.test1183
9 files changed, 5248 insertions, 2759 deletions
diff --git a/tests/option.test b/tests/option.test
index 2cdd675..2cf574e 100644
--- a/tests/option.test
+++ b/tests/option.test
@@ -6,16 +6,16 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: option.test,v 1.6 2004/05/23 17:34:49 dkf Exp $
+# RCS: @(#) $Id: option.test,v 1.7 2008/08/28 08:52:05 aniap Exp $
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
testConstraint appNameIsTktest [expr {[winfo name .] eq "tktest"}]
-catch {destroy .op1}
-catch {destroy .op2}
+deleteWindows
set appName [winfo name .]
# First, test basic retrievals, being sure to trigger all the various
@@ -29,6 +29,7 @@ frame .op1.op4 -class Class3
frame .op2.op5 -class Class2
frame .op1.op3.op6 -class Class4
+# Configurations for tests 1.* - 12.*
option clear
option add *Color1 red
option add *x blue
@@ -40,97 +41,254 @@ option add $appName.Class1.Class3.y brown
option add $appName*op6*Color2 black
option add $appName*Class1.op1.Color2 grey
-test option-1.1 {basic option retrieval} {option get . x Color1} blue
-test option-1.2 {basic option retrieval} {option get . y Color1} red
-test option-1.3 {basic option retrieval} {option get . z Color1} red
-test option-1.4 {basic option retrieval} {option get . x Color2} blue
-test option-1.5 {basic option retrieval} {option get . y Color2} {}
-test option-1.6 {basic option retrieval} {option get . z Color2} {}
-
-test option-2.1 {basic option retrieval} {option get .op1 x Color1} green
-test option-2.2 {basic option retrieval} {option get .op1 y Color1} red
-test option-2.3 {basic option retrieval} {option get .op1 z Color1} red
-test option-2.4 {basic option retrieval} {option get .op1 x Color2} green
-test option-2.5 {basic option retrieval} {option get .op1 y Color2} {}
-test option-2.6 {basic option retrieval} {option get .op1 z Color2} {}
-
-test option-3.1 {basic option retrieval} {option get .op1.op3 x Color1} yellow
-test option-3.2 {basic option retrieval} {option get .op1.op3 y Color1} red
-test option-3.3 {basic option retrieval} {option get .op1.op3 z Color1} red
-test option-3.4 {basic option retrieval} {option get .op1.op3 x Color2} yellow
-test option-3.5 {basic option retrieval} {option get .op1.op3 y Color2} {}
-test option-3.6 {basic option retrieval} {option get .op1.op3 z Color2} {}
-
-test option-4.1 {basic option retrieval} {option get .op1.op3.op6 x Color1} blue
-test option-4.2 {basic option retrieval} {option get .op1.op3.op6 y Color1} red
-test option-4.3 {basic option retrieval} {option get .op1.op3.op6 z Color1} red
-test option-4.4 {basic option retrieval} {option get .op1.op3.op6 x Color2} black
-test option-4.5 {basic option retrieval} {option get .op1.op3.op6 y Color2} black
-test option-4.6 {basic option retrieval} {option get .op1.op3.op6 z Color2} black
-
-test option-5.1 {basic option retrieval} {option get .op1.op4 x Color1} blue
-test option-5.2 {basic option retrieval} {option get .op1.op4 y Color1} brown
-test option-5.3 {basic option retrieval} {option get .op1.op4 z Color1} red
-test option-5.4 {basic option retrieval} {option get .op1.op4 x Color2} blue
-test option-5.5 {basic option retrieval} {option get .op1.op4 y Color2} brown
-test option-5.6 {basic option retrieval} {option get .op1.op4 z Color2} {}
-
-test option-6.1 {basic option retrieval} {option get .op2 x Color1} orange
-test option-6.2 {basic option retrieval} {option get .op2 y Color1} orange
-test option-6.3 {basic option retrieval} {option get .op2 z Color1} orange
-test option-6.4 {basic option retrieval} {option get .op2 x Color2} blue
-test option-6.5 {basic option retrieval} {option get .op2 y Color2} {}
-test option-6.6 {basic option retrieval} {option get .op2 z Color2} {}
-
-test option-7.1 {basic option retrieval} {option get .op2.op5 x Color1} orange
-test option-7.2 {basic option retrieval} {option get .op2.op5 y Color1} orange
-test option-7.3 {basic option retrieval} {option get .op2.op5 z Color1} orange
-test option-7.4 {basic option retrieval} {option get .op2.op5 x Color2} purple
-test option-7.5 {basic option retrieval} {option get .op2.op5 y Color2} purple
-test option-7.6 {basic option retrieval} {option get .op2.op5 z Color2} purple
+test option-1.1 {basic option retrieval} -body {
+ option get . x Color1
+} -result blue
+test option-1.2 {basic option retrieval} -body {
+ option get . y Color1
+} -result red
+test option-1.3 {basic option retrieval} -body {
+ option get . z Color1
+} -result red
+test option-1.4 {basic option retrieval} -body {
+ option get . x Color2
+} -result blue
+test option-1.5 {basic option retrieval} -body {
+ option get . y Color2
+} -result {}
+test option-1.6 {basic option retrieval} -body {
+ option get . z Color2
+} -result {}
+
+
+test option-2.1 {basic option retrieval} -body {
+ option get .op1 x Color1
+} -result green
+test option-2.2 {basic option retrieval} -body {
+ option get .op1 y Color1
+} -result red
+test option-2.3 {basic option retrieval} -body {
+ option get .op1 z Color1
+} -result red
+test option-2.4 {basic option retrieval} -body {
+ option get .op1 x Color2
+} -result green
+test option-2.5 {basic option retrieval} -body {
+ option get .op1 y Color2
+} -result {}
+test option-2.6 {basic option retrieval} -body {
+ option get .op1 z Color2
+} -result {}
+
+
+test option-3.1 {basic option retrieval} -body {
+ option get .op1.op3 x Color1
+} -result yellow
+test option-3.2 {basic option retrieval} -body {
+ option get .op1.op3 y Color1
+} -result red
+test option-3.3 {basic option retrieval} -body {
+ option get .op1.op3 z Color1
+} -result red
+test option-3.4 {basic option retrieval} -body {
+ option get .op1.op3 x Color2
+} -result yellow
+test option-3.5 {basic option retrieval} -body {
+ option get .op1.op3 y Color2
+} -result {}
+test option-3.6 {basic option retrieval} -body {
+ option get .op1.op3 z Color2
+} -result {}
+
+
+test option-4.1 {basic option retrieval} -body {
+ option get .op1.op3.op6 x Color1
+} -result blue
+test option-4.2 {basic option retrieval} -body {
+ option get .op1.op3.op6 y Color1
+} -result red
+test option-4.3 {basic option retrieval} -body {
+ option get .op1.op3.op6 z Color1
+} -result red
+test option-4.4 {basic option retrieval} -body {
+ option get .op1.op3.op6 x Color2
+} -result black
+test option-4.5 {basic option retrieval} -body {
+ option get .op1.op3.op6 y Color2
+} -result black
+test option-4.6 {basic option retrieval} -body {
+ option get .op1.op3.op6 z Color2
+} -result black
+
+
+test option-5.1 {basic option retrieval} -body {
+ option get .op1.op4 x Color1
+} -result blue
+test option-5.2 {basic option retrieval} -body {
+ option get .op1.op4 y Color1
+} -result brown
+test option-5.3 {basic option retrieval} -body {
+ option get .op1.op4 z Color1
+} -result red
+test option-5.4 {basic option retrieval} -body {
+ option get .op1.op4 x Color2
+} -result blue
+test option-5.5 {basic option retrieval} -body {
+ option get .op1.op4 y Color2
+} -result brown
+test option-5.6 {basic option retrieval} -body {
+ option get .op1.op4 z Color2
+} -result {}
+
+
+test option-6.1 {basic option retrieval} -body {
+ option get .op2 x Color1
+} -result orange
+test option-6.2 {basic option retrieval} -body {
+ option get .op2 y Color1
+} -result orange
+test option-6.3 {basic option retrieval} -body {
+ option get .op2 z Color1
+} -result orange
+test option-6.4 {basic option retrieval} -body {
+ option get .op2 x Color2
+} -result blue
+test option-6.5 {basic option retrieval} -body {
+ option get .op2 y Color2
+} -result {}
+test option-6.6 {basic option retrieval} -body {
+ option get .op2 z Color2
+} -result {}
+
+
+test option-7.1 {basic option retrieval} -body {
+ option get .op2.op5 x Color1
+} -result orange
+test option-7.2 {basic option retrieval} -body {
+ option get .op2.op5 y Color1
+} -result orange
+test option-7.3 {basic option retrieval} -body {
+ option get .op2.op5 z Color1
+} -result orange
+test option-7.4 {basic option retrieval} -body {
+ option get .op2.op5 x Color2
+} -result purple
+test option-7.5 {basic option retrieval} -body {
+ option get .op2.op5 y Color2
+} -result purple
+test option-7.6 {basic option retrieval} -body {
+ option get .op2.op5 z Color2
+} -result purple
+
# Now try similar tests to above, except jump around non-hierarchically
# between windows to make sure that the option stacks are pushed and
# popped correctly.
option get . foo Foo
-test option-8.1 {stack pushing/popping} {option get .op2.op5 x Color1} orange
-test option-8.2 {stack pushing/popping} {option get .op2.op5 y Color1} orange
-test option-8.3 {stack pushing/popping} {option get .op2.op5 z Color1} orange
-test option-8.4 {stack pushing/popping} {option get .op2.op5 x Color2} purple
-test option-8.5 {stack pushing/popping} {option get .op2.op5 y Color2} purple
-test option-8.6 {stack pushing/popping} {option get .op2.op5 z Color2} purple
-
-test option-9.1 {stack pushing/popping} {option get . x Color1} blue
-test option-9.2 {stack pushing/popping} {option get . y Color1} red
-test option-9.3 {stack pushing/popping} {option get . z Color1} red
-test option-9.4 {stack pushing/popping} {option get . x Color2} blue
-test option-9.5 {stack pushing/popping} {option get . y Color2} {}
-test option-9.6 {stack pushing/popping} {option get . z Color2} {}
-
-test option-10.1 {stack pushing/popping} {option get .op1.op3.op6 x Color1} blue
-test option-10.2 {stack pushing/popping} {option get .op1.op3.op6 y Color1} red
-test option-10.3 {stack pushing/popping} {option get .op1.op3.op6 z Color1} red
-test option-10.4 {stack pushing/popping} {option get .op1.op3.op6 x Color2} black
-test option-10.5 {stack pushing/popping} {option get .op1.op3.op6 y Color2} black
-test option-10.6 {stack pushing/popping} {option get .op1.op3.op6 z Color2} black
-
-test option-11.1 {stack pushing/popping} {option get .op1.op3 x Color1} yellow
-test option-11.2 {stack pushing/popping} {option get .op1.op3 y Color1} red
-test option-11.3 {stack pushing/popping} {option get .op1.op3 z Color1} red
-test option-11.4 {stack pushing/popping} {option get .op1.op3 x Color2} yellow
-test option-11.5 {stack pushing/popping} {option get .op1.op3 y Color2} {}
-test option-11.6 {stack pushing/popping} {option get .op1.op3 z Color2} {}
-
-test option-12.1 {stack pushing/popping} {option get .op1 x Color1} green
-test option-12.2 {stack pushing/popping} {option get .op1 y Color1} red
-test option-12.3 {stack pushing/popping} {option get .op1 z Color1} red
-test option-12.4 {stack pushing/popping} {option get .op1 x Color2} green
-test option-12.5 {stack pushing/popping} {option get .op1 y Color2} {}
-test option-12.6 {stack pushing/popping} {option get .op1 z Color2} {}
+test option-8.1 {stack pushing/popping} -body {
+ option get .op2.op5 x Color1
+} -result orange
+test option-8.2 {stack pushing/popping} -body {
+ option get .op2.op5 y Color1
+} -result orange
+test option-8.3 {stack pushing/popping} -body {
+ option get .op2.op5 z Color1
+} -result orange
+test option-8.4 {stack pushing/popping} -body {
+ option get .op2.op5 x Color2
+} -result purple
+test option-8.5 {stack pushing/popping} -body {
+ option get .op2.op5 y Color2
+} -result purple
+test option-8.6 {stack pushing/popping} -body {
+ option get .op2.op5 z Color2
+} -result purple
+
+
+test option-9.1 {stack pushing/popping} -body {
+ option get . x Color1
+} -result blue
+test option-9.2 {stack pushing/popping} -body {
+ option get . y Color1
+} -result red
+test option-9.3 {stack pushing/popping} -body {
+ option get . z Color1
+} -result red
+test option-9.4 {stack pushing/popping} -body {
+ option get . x Color2
+} -result blue
+test option-9.5 {stack pushing/popping} -body {
+ option get . y Color2
+} -result {}
+test option-9.6 {stack pushing/popping} -body {
+ option get . z Color2
+} -result {}
+
+
+test option-10.1 {stack pushing/popping} -body {
+ option get .op1.op3.op6 x Color1
+} -result blue
+test option-10.2 {stack pushing/popping} -body {
+ option get .op1.op3.op6 y Color1
+} -result red
+test option-10.3 {stack pushing/popping} -body {
+ option get .op1.op3.op6 z Color1
+} -result red
+test option-10.4 {stack pushing/popping} -body {
+ option get .op1.op3.op6 x Color2
+} -result black
+test option-10.5 {stack pushing/popping} -body {
+ option get .op1.op3.op6 y Color2
+} -result black
+test option-10.6 {stack pushing/popping} -body {
+ option get .op1.op3.op6 z Color2
+} -result black
+
+
+test option-11.1 {stack pushing/popping} -body {
+ option get .op1.op3 x Color1
+} -result yellow
+test option-11.2 {stack pushing/popping} -body {
+ option get .op1.op3 y Color1
+} -result red
+test option-11.3 {stack pushing/popping} -body {
+ option get .op1.op3 z Color1
+} -result red
+test option-11.4 {stack pushing/popping} -body {
+ option get .op1.op3 x Color2
+} -result yellow
+test option-11.5 {stack pushing/popping} -body {
+ option get .op1.op3 y Color2
+} -result {}
+test option-11.6 {stack pushing/popping} -body {
+ option get .op1.op3 z Color2
+} -result {}
+
+
+test option-12.1 {stack pushing/popping} -body {
+ option get .op1 x Color1
+} -result green
+test option-12.2 {stack pushing/popping} -body {
+ option get .op1 y Color1
+} -result red
+test option-12.3 {stack pushing/popping} -body {
+ option get .op1 z Color1
+} -result red
+test option-12.4 {stack pushing/popping} -body {
+ option get .op1 x Color2
+} -result green
+test option-12.5 {stack pushing/popping} -body {
+ option get .op1 y Color2
+} -result {}
+test option-12.6 {stack pushing/popping} -body {
+ option get .op1 z Color2
+} -result {}
# Test the major priority levels (widgetDefault, etc.)
+# Configurations for tests 13.*
+option clear
option add $appName.op1.a 100 100
option add $appName.op1.A interactive interactive
option add $appName.op1.b userDefault userDefault
@@ -138,92 +296,127 @@ option add $appName.op1.B startupFile startupFile
option add $appName.op1.c widgetDefault widgetDefault
option add $appName.op1.C 0 0
-test option-13.1 {priority levels} {option get .op1 a A} 100
-test option-13.2 {priority levels} {option get .op1 b A} interactive
-test option-13.3 {priority levels} {option get .op1 b B} userDefault
-test option-13.4 {priority levels} {option get .op1 c B} startupFile
-test option-13.5 {priority levels} {option get .op1 c C} widgetDefault
+test option-13.1 {priority levels} -body {
+ option get .op1 a A
+} -result 100
+test option-13.2 {priority levels} -body {
+ option get .op1 b A
+} -result interactive
+test option-13.3 {priority levels} -body {
+ option get .op1 b B
+} -result userDefault
+test option-13.4 {priority levels} -body {
+ option get .op1 c B
+} -result startupFile
+test option-13.5 {priority levels} -body {
+ option get .op1 c C
+} -result widgetDefault
option add $appName.op1.B file2 widget
-test option-13.6 {priority levels} {option get .op1 c B} startupFile
+test option-13.6 {priority levels} -body {
+ option get .op1 c B
+} -result startupFile
option add $appName.op1.B file2 startupFile
-test option-13.7 {priority levels} {option get .op1 c B} file2
+test option-13.7 {priority levels} -body {
+ option get .op1 c B
+} -result file2
+
# Test various error conditions
-test option-14.1 {error conditions} {
- list [catch {option} msg] $msg
-} {1 {wrong # args: should be "option cmd arg ?arg ...?"}}
-test option-14.2 {error conditions} {
- list [catch {option x} msg] $msg
-} {1 {bad option "x": must be add, clear, get, or readfile}}
-test option-14.3 {error conditions} {
- list [catch {option foo 3} msg] $msg
-} {1 {bad option "foo": must be add, clear, get, or readfile}}
-test option-14.4 {error conditions} {
- list [catch {option add 3} msg] $msg
-} {1 {wrong # args: should be "option add pattern value ?priority?"}}
-test option-14.5 {error conditions} {
- list [catch {option add . a b c} msg] $msg
-} {1 {wrong # args: should be "option add pattern value ?priority?"}}
-test option-14.6 {error conditions} {
- list [catch {option add . a -1} msg] $msg
-} {1 {bad priority level "-1": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}}
-test option-14.7 {error conditions} {
- list [catch {option add . a 101} msg] $msg
-} {1 {bad priority level "101": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}}
-test option-14.8 {error conditions} {
- list [catch {option add . a gorp} msg] $msg
-} {1 {bad priority level "gorp": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}}
-test option-14.9 {error conditions} {
- list [catch {option get 3} msg] $msg
-} {1 {wrong # args: should be "option get window name class"}}
-test option-14.10 {error conditions} {
- list [catch {option get 3 4} msg] $msg
-} {1 {wrong # args: should be "option get window name class"}}
-test option-14.11 {error conditions} {
- list [catch {option get 3 4 5 6} msg] $msg
-} {1 {wrong # args: should be "option get window name class"}}
-test option-14.12 {error conditions} {
- list [catch {option get .gorp.gorp a A} msg] $msg
-} {1 {bad window path name ".gorp.gorp"}}
+test option-14.1 {error conditions} -body {
+ option
+} -returnCodes error -result {wrong # args: should be "option cmd arg ?arg ...?"}
+test option-14.2 {error conditions} -body {
+ option x
+} -returnCodes error -result {bad option "x": must be add, clear, get, or readfile}
+test option-14.3 {error conditions} -body {
+ option foo 3
+} -returnCodes error -result {bad option "foo": must be add, clear, get, or readfile}
+test option-14.4 {error conditions} -body {
+ option add 3
+} -returnCodes error -result {wrong # args: should be "option add pattern value ?priority?"}
+test option-14.5 {error conditions} -body {
+ option add . a b c
+} -returnCodes error -result {wrong # args: should be "option add pattern value ?priority?"}
+test option-14.6 {error conditions} -body {
+ option add . a -1
+} -returnCodes error -result {bad priority level "-1": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}
+test option-14.7 {error conditions} -body {
+ option add . a 101
+} -returnCodes error -result {bad priority level "101": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}
+test option-14.8 {error conditions} -body {
+ option add . a gorp
+} -returnCodes error -result {bad priority level "gorp": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}
+test option-14.9 {error conditions} -body {
+ option get 3
+} -returnCodes error -result {wrong # args: should be "option get window name class"}
+test option-14.10 {error conditions} -body {
+ option get 3 4
+} -returnCodes error -result {wrong # args: should be "option get window name class"}
+test option-14.11 {error conditions} -body {
+ option get 3 4 5 6
+} -returnCodes error -result {wrong # args: should be "option get window name class"}
+test option-14.12 {error conditions} -body {
+ option get .gorp.gorp a A
+} -returnCodes error -result {bad window path name ".gorp.gorp"}
+
set option1 [file join [testsDirectory] option.file1]
-set option2 [file join [testsDirectory] option.file2]
-
-test option-15.1 {database files} {
- list [catch {option read non-existent} msg] $msg
-} {1 {couldn't open "non-existent": no such file or directory}}
-option read $option1
-test option-15.2 {database files} {option get . x1 color} blue
-test option-15.3 {database files} appNameIsTktest {option get . x2 color} green
-test option-15.4 {database files} {option get . x3 color} purple
-test option-15.5 {database files} {option get . {x 4} color} brown
-test option-15.6 {database files} {option get . x6 color} {}
-test option-15.7 {database files} {
- list [catch {option read $option1 widget foo} msg] $msg
-} {1 {wrong # args: should be "option readfile fileName ?priority?"}}
-option add *x3 burgundy
-catch {option read $option1 userDefault}
-test option-15.8 {database files} {option get . x3 color} burgundy
-test option-15.9 {database files} {
- list [catch {option read $option2} msg] $msg
-} {1 {missing colon on line 2}}
-
-test option-16.1 {ReadOptionFile} {
+test option-15.1 {database files} -body {
+ option read non-existent
+} -returnCodes error -result {couldn't open "non-existent": no such file or directory}
+test option-15.2 {database files} -body {
+ option read $option1
+ option get . x1 color
+} -result blue
+test option-15.3 {database files} -constraints appNameIsTktest -body {
+ option read $option1
+ option get . x2 color
+} -result green
+test option-15.4 {database files} -body {
+ option read $option1
+ option get . x3 color
+} -result purple
+test option-15.5 {database files} -body {
+ option read $option1
+ option get . {x 4} color
+} -result brown
+test option-15.6 {database files} -body {
+ option read $option1
+ option get . x6 color
+} -result {}
+test option-15.7 {database files} -body {
+ option read $option1 widget foo
+} -returnCodes error -result {wrong # args: should be "option readfile fileName ?priority?"}
+
+test option-15.8 {database files} -body {
+ option add *x3 burgundy
+ catch {option read $option1 userDefault}
+ option get . x3 color
+} -result burgundy
+test option-15.9 {database files} -body {
+ set option2 [file join [testsDirectory] option.file2]
+ option read $option2
+} -returnCodes error -result {missing colon on line 2}
+
+
+test option-16.1 {ReadOptionFile} -body {
set option3 [makeFile {} option.file3]
set file [open $option3 w]
fconfigure $file -translation crlf
puts $file "*x7: true\n*x8: false"
close $file
option read $option3 userDefault
- set result [list [option get . x7 color] [option get . x8 color]]
+ list [option get . x7 color] [option get . x8 color]
+} -cleanup {
removeFile $option3
- set result
-} {true false}
+} -result {true false}
-catch {destroy .op1}
-catch {destroy .op2}
+deleteWindows
# cleanup
cleanupTests
return
+
+
+
diff --git a/tests/place.test b/tests/place.test
index c2a4042..7602766 100644
--- a/tests/place.test
+++ b/tests/place.test
@@ -5,9 +5,10 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: place.test,v 1.11 2004/09/16 18:01:20 pspjuth Exp $
+# RCS: @(#) $Id: place.test,v 1.12 2008/08/28 08:52:05 aniap Exp $
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
@@ -17,6 +18,7 @@ testConstraint memory [llength [info commands memory]]
# XXX - This test file is woefully incomplete. At present, only a
# few of the features are tested.
+# Widgets used in tests 1.* - 8.*
toplevel .t -width 300 -height 200 -bd 0
wm geom .t +0+0
frame .t.f -width 154 -height 84 -bd 2 -relief raised
@@ -24,145 +26,181 @@ place .t.f -x 48 -y 38
frame .t.f2 -width 30 -height 60 -bd 2 -relief raised
update
-test place-1.1 {Tk_PlaceCmd procedure, "info" option} {
+test place-1.1 {Tk_PlaceCmd procedure, "info" option} -setup {
+ place forget .t.f2
+} -body {
place .t.f2 -x 0
place info .t.f2
-} {-in .t -x 0 -relx 0 -y 0 -rely 0 -width {} -relwidth {} -height {} -relheight {} -anchor nw -bordermode inside}
-test place-1.2 {Tk_PlaceCmd procedure, "info" option} {
+} -result {-in .t -x 0 -relx 0 -y 0 -rely 0 -width {} -relwidth {} -height {} -relheight {} -anchor nw -bordermode inside}
+test place-1.2 {Tk_PlaceCmd procedure, "info" option} -setup {
+ place forget .t.f2
+} -body {
place .t.f2 -x 1 -y 2 -width 3 -height 4 -relx 0.1 -rely 0.2 \
- -relwidth 0.3 -relheight 0.4 -anchor se -in .t.f \
- -bordermode outside
+ -relwidth 0.3 -relheight 0.4 -anchor se -in .t.f \
+ -bordermode outside
place info .t.f2
-} {-in .t.f -x 1 -relx 0.1 -y 2 -rely 0.2 -width 3 -relwidth 0.3 -height 4 -relheight 0.4 -anchor se -bordermode outside}
-test place-1.3 {Tk_PlaceCmd procedure, "info" option} {
+} -result {-in .t.f -x 1 -relx 0.1 -y 2 -rely 0.2 -width 3 -relwidth 0.3 -height 4 -relheight 0.4 -anchor se -bordermode outside}
+test place-1.3 {Tk_PlaceCmd procedure, "info" option} -setup {
+ place forget .t.f2
+ destroy .t.a.b
+} -body {
# Make sure the result is built as a proper list by using a space in parent
frame ".t.a b"
place .t.f2 -x 1 -y 2 -width {} -height 4 -relx 0.2 -rely 0.2 \
- -relwidth 0.3 -relheight {} -anchor w -in ".t.a b" \
- -bordermode ignore
- set res [place info .t.f2]
- destroy ".t.a b"
- set res
-} {-in {.t.a b} -x 1 -relx 0.2 -y 2 -rely 0.2 -width {} -relwidth 0.3 -height 4 -relheight {} -anchor w -bordermode ignore}
-
-test place-2.1 {ConfigureSlave procedure, -height option} {
- list [catch {place .t.f2 -height abcd} msg] $msg
-} {1 {bad screen distance "abcd"}}
-test place-2.2 {ConfigureSlave procedure, -height option} {
+ -relwidth 0.3 -relheight {} -anchor w -in ".t.a b" \
+ -bordermode ignore
+ place info .t.f2
+} -cleanup {
+ destroy ".t.a.b"
+} -result {-in {.t.a b} -x 1 -relx 0.2 -y 2 -rely 0.2 -width {} -relwidth 0.3 -height 4 -relheight {} -anchor w -bordermode ignore}
+
+
+test place-2.1 {ConfigureSlave procedure, -height option} -body {
+ place .t.f2 -height abcd
+} -returnCodes error -result {bad screen distance "abcd"}
+test place-2.2 {ConfigureSlave procedure, -height option} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -height 40
update
winfo height .t.f2
-} {40}
-test place-2.3 {ConfigureSlave procedure, -height option} {
+} -result {40}
+test place-2.3 {ConfigureSlave procedure, -height option} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -height 120
update
place .t.f2 -height {}
update
winfo height .t.f2
-} {60}
+} -result {60}
-test place-3.1 {ConfigureSlave procedure, -relheight option} {
- list [catch {place .t.f2 -relheight abcd} msg] $msg
-} {1 {expected floating-point number but got "abcd"}}
-test place-3.2 {ConfigureSlave procedure, -relheight option} {
+
+test place-3.1 {ConfigureSlave procedure, -relheight option} -body {
+ place .t.f2 -relheight abcd
+} -returnCodes error -result {expected floating-point number but got "abcd"}
+test place-3.2 {ConfigureSlave procedure, -relheight option} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -relheight .5
update
winfo height .t.f2
-} {40}
-test place-3.3 {ConfigureSlave procedure, -relheight option} {
+} -result {40}
+test place-3.3 {ConfigureSlave procedure, -relheight option} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -relheight .8
update
place .t.f2 -relheight {}
update
winfo height .t.f2
-} {60}
+} -result {60}
+
-test place-4.1 {ConfigureSlave procedure, bad -in options} {
+test place-4.1 {ConfigureSlave procedure, bad -in options} -setup {
+ place forget .t.f2
+} -body {
+ place .t.f2 -in .t.f2
+} -returnCodes error -result {can't place .t.f2 relative to itself}
+test place-4.2 {ConfigureSlave procedure, bad -in option} -setup {
place forget .t.f2
- list [catch {place .t.f2 -in .t.f2} msg] $msg
-} [list 1 "can't place .t.f2 relative to itself"]
-test place-4.2 {ConfigureSlave procedure, bad -in option} {
+} -body {
+ set result [list [winfo manager .t.f2]]
+ catch {place .t.f2 -in .t.f2}
+ lappend result [winfo manager .t.f2]
+} -result {{} {}}
+test place-4.3 {ConfigureSlave procedure, bad -in option} -setup {
place forget .t.f2
- list [winfo manager .t.f2] \
- [catch {place .t.f2 -in .t.f2} err] $err \
- [winfo manager .t.f2]
-} {{} 1 {can't place .t.f2 relative to itself} {}}
-test place-4.3 {ConfigureSlave procedure, bad -in option} {
+} -body {
+ winfo manager .t.f2
+ place .t.f2 -in .t.f2
+} -returnCodes error -result {can't place .t.f2 relative to itself}
+test place-4.4 {ConfigureSlave procedure, bad -in option} -setup {
place forget .t.f2
- list [catch {place .t.f2 -in .} msg] $msg
-} [list 1 "can't place .t.f2 relative to ."]
+} -body {
+ place .t.f2 -in .
+} -returnCodes error -result {can't place .t.f2 relative to .}
-test place-5.1 {ConfigureSlave procedure, -relwidth option} {
- list [catch {place .t.f2 -relwidth abcd} msg] $msg
-} {1 {expected floating-point number but got "abcd"}}
-test place-5.2 {ConfigureSlave procedure, -relwidth option} {
+
+test place-5.1 {ConfigureSlave procedure, -relwidth option} -body {
+ place .t.f2 -relwidth abcd
+} -returnCodes error -result {expected floating-point number but got "abcd"}
+test place-5.2 {ConfigureSlave procedure, -relwidth option} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -relwidth .5
update
winfo width .t.f2
-} {75}
-test place-5.3 {ConfigureSlave procedure, -relwidth option} {
+} -result {75}
+test place-5.3 {ConfigureSlave procedure, -relwidth option} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -relwidth .8
update
place .t.f2 -relwidth {}
update
winfo width .t.f2
-} {30}
+} -result {30}
-test place-6.1 {ConfigureSlave procedure, -width option} {
- list [catch {place .t.f2 -width abcd} msg] $msg
-} {1 {bad screen distance "abcd"}}
-test place-6.2 {ConfigureSlave procedure, -width option} {
+test place-6.1 {ConfigureSlave procedure, -width option} -body {
+ place .t.f2 -width abcd
+} -returnCodes error -result {bad screen distance "abcd"}
+test place-6.2 {ConfigureSlave procedure, -width option} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -width 100
update
winfo width .t.f2
-} {100}
-test place-6.3 {ConfigureSlave procedure, -width option} {
+} -result {100}
+test place-6.3 {ConfigureSlave procedure, -width option} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -width 120
update
place .t.f2 -width {}
update
winfo width .t.f2
-} {30}
+} -result {30}
+
-test place-7.1 {ReconfigurePlacement procedure, computing position} {
+test place-7.1 {ReconfigurePlacement procedure, computing position} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -x -2 -relx .5 -y 3 -rely .4
update
winfo geometry .t.f2
-} {30x60+123+75}
-test place-7.2 {ReconfigurePlacement procedure, position rounding} {
+} -result {30x60+123+75}
+test place-7.2 {ReconfigurePlacement procedure, position rounding} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -x -1.4 -y -2.3
update
winfo geometry .t.f2
-} {30x60+49+38}
-test place-7.3 {ReconfigurePlacement procedure, position rounding} {
+} -result {30x60+49+38}
+test place-7.3 {ReconfigurePlacement procedure, position rounding} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -x 1.4 -y 2.3
update
winfo geometry .t.f2
-} {30x60+51+42}
-test place-7.4 {ReconfigurePlacement procedure, position rounding} {
+} -result {30x60+51+42}
+test place-7.4 {ReconfigurePlacement procedure, position rounding} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -x -1.6 -y -2.7
update
winfo geometry .t.f2
-} {30x60+48+37}
-test place-7.5 {ReconfigurePlacement procedure, position rounding} {
+} -result {30x60+48+37}
+test place-7.5 {ReconfigurePlacement procedure, position rounding} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -x 1.6 -y 2.7
update
winfo geometry .t.f2
-} {30x60+52+43}
-test place-7.6 {ReconfigurePlacement procedure, position rounding} {
+} -result {30x60+52+43}
+test place-7.6 {ReconfigurePlacement procedure, position rounding} -setup {
+ destroy .t.f3
+} -body {
frame .t.f3 -width 100 -height 100 -bg #f00000 -bd 0
place .t.f3 -x 0 -y 0
raise .t.f2
@@ -170,38 +208,44 @@ test place-7.6 {ReconfigurePlacement procedure, position rounding} {
place .t.f2 -in .t.f3 -relx .303 -rely .406 -relwidth .304 -relheight .206
update
winfo geometry .t.f2
-} {31x20+30+41}
-catch {destroy .t.f3}
-test place-7.7 {ReconfigurePlacement procedure, computing size} {
+} -cleanup {
+ destroy .t.f3
+} -result {31x20+30+41}
+test place-7.7 {ReconfigurePlacement procedure, computing size} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -width 120 -height 89
update
list [winfo width .t.f2] [winfo height .t.f2]
-} {120 89}
-test place-7.8 {ReconfigurePlacement procedure, computing size} {
+} -result {120 89}
+test place-7.8 {ReconfigurePlacement procedure, computing size} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -relwidth .4 -relheight .5
update
list [winfo width .t.f2] [winfo height .t.f2]
-} {60 40}
-test place-7.9 {ReconfigurePlacement procedure, computing size} {
+} -result {60 40}
+test place-7.9 {ReconfigurePlacement procedure, computing size} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -width 10 -relwidth .4 -height -4 -relheight .5
update
list [winfo width .t.f2] [winfo height .t.f2]
-} {70 36}
-test place-7.10 {ReconfigurePlacement procedure, computing size} {
+} -result {70 36}
+test place-7.10 {ReconfigurePlacement procedure, computing size} -setup {
place forget .t.f2
+} -body {
place .t.f2 -in .t.f -width 10 -relwidth .4 -height -4 -relheight .5
place .t.f2 -width {} -relwidth {} -height {} -relheight {}
update
list [winfo width .t.f2] [winfo height .t.f2]
-} {30 60}
+} -result {30 60}
-test place-8.1 {MasterStructureProc, mapping and unmapping slaves} {
+test place-8.1 {MasterStructureProc, mapping and unmapping slaves} -setup {
place forget .t.f2
place forget .t.f
+} -body {
place .t.f2 -relx 1.0 -rely 1.0 -anchor sw
update
set result [winfo ismapped .t.f2]
@@ -214,10 +258,11 @@ test place-8.1 {MasterStructureProc, mapping and unmapping slaves} {
wm deiconify .t
update
lappend result [winfo ismapped .t.f2]
-} {1 0 40 30 0 1}
-test place-8.2 {MasterStructureProc, mapping and unmapping slaves} {
+} -result {1 0 40 30 0 1}
+test place-8.2 {MasterStructureProc, mapping and unmapping slaves} -setup {
place forget .t.f2
place forget .t.f
+} -body {
place .t.f -x 0 -y 0 -width 200 -height 100
place .t.f2 -in .t.f -relx 1.0 -rely 1.0 -anchor sw -width 50 -height 20
update
@@ -231,130 +276,153 @@ test place-8.2 {MasterStructureProc, mapping and unmapping slaves} {
wm deiconify .t
update
lappend result [winfo ismapped .t.f2]
-} {1 0 42 32 0 1}
-
-test place-9.1 {PlaceObjCmd} {
- list [catch {place} msg] $msg
-} [list 1 "wrong # args: should be \"place option|pathName args\""]
-test place-9.2 {PlaceObjCmd} {
- list [catch {place foo} msg] $msg
-} [list 1 "wrong # args: should be \"place option|pathName args\""]
-test place-9.3 {PlaceObjCmd} {
- catch {destroy .foo}
- list [catch {place .foo bar} msg] $msg
-} [list 1 "bad window path name \".foo\""]
-test place-9.4 {PlaceObjCmd} {
- catch {destroy .foo}
- list [catch {place bar .foo} msg] $msg
-} [list 1 "bad window path name \".foo\""]
-test place-9.5 {PlaceObjCmd} {
- catch {destroy .foo}
+} -result {1 0 42 32 0 1}
+destroy .t
+
+
+test place-9.1 {PlaceObjCmd} -body {
+ place
+} -returnCodes error -result {wrong # args: should be "place option|pathName args"}
+test place-9.2 {PlaceObjCmd} -body {
+ place foo
+} -returnCodes error -result {wrong # args: should be "place option|pathName args"}
+test place-9.3 {PlaceObjCmd} -setup {
+ destroy .foo
+} -body {
+ place .foo bar
+} -returnCodes error -result {bad window path name ".foo"}
+test place-9.4 {PlaceObjCmd} -setup {
+ destroy .foo
+} -body {
+ place bar .foo
+} -cleanup {
+ destroy .foo
+} -returnCodes error -result {bad window path name ".foo"}
+test place-9.5 {PlaceObjCmd} -setup {
+ destroy .foo
+} -body {
frame .foo
- set res [list [catch {place badopt .foo} msg] $msg]
+ place badopt .foo
+} -cleanup {
destroy .foo
- set res
-} [list 1 "bad option \"badopt\": must be configure, forget, info, or slaves"]
-test place-9.6 {PlaceObjCmd, configure errors} {
- catch {destroy .foo}
+} -returnCodes error -result {bad option "badopt": must be configure, forget, info, or slaves}
+test place-9.6 {PlaceObjCmd, configure errors} -setup {
+ destroy .foo
+} -body {
frame .foo
- set res [list [catch {place configure .foo} msg] $msg]
+ place configure .foo
+} -cleanup {
+ destroy .foo
+} -returnCodes ok -result {}
+test place-9.7 {PlaceObjCmd, configure errors} -setup {
destroy .foo
- set res
-} [list 0 ""]
-test place-9.7 {PlaceObjCmd, configure errors} {
- catch {destroy .foo}
+} -body {
frame .foo
- set res [list [catch {place configure .foo bar} msg] $msg]
+ place configure .foo bar
+} -cleanup {
+ destroy .foo
+} -returnCodes ok -result {}
+test place-9.8 {PlaceObjCmd, configure} -setup {
destroy .foo
- set res
-} [list 0 ""]
-test place-9.8 {PlaceObjCmd, configure} {
- catch {destroy .foo}
+} -body {
frame .foo
place .foo -x 0 -y 0
- set res [place configure .foo]
+ place configure .foo
+} -cleanup {
destroy .foo
- set res
-} [list {-anchor {} {} nw nw} {-bordermode {} {} inside inside} {-height {} {} {} {}} {-in {} {} {} .} {-relheight {} {} {} {}} {-relwidth {} {} {} {}} {-relx {} {} 0 0.0} {-rely {} {} 0 0.0} {-width {} {} {} {}} {-x {} {} 0 0} {-y {} {} 0 0}]
-test place-9.9 {PlaceObjCmd, configure} {
- catch {destroy .foo}
+} -result [list {-anchor {} {} nw nw} {-bordermode {} {} inside inside} {-height {} {} {} {}} {-in {} {} {} .} {-relheight {} {} {} {}} {-relwidth {} {} {} {}} {-relx {} {} 0 0.0} {-rely {} {} 0 0.0} {-width {} {} {} {}} {-x {} {} 0 0} {-y {} {} 0 0}]
+test place-9.9 {PlaceObjCmd, configure} -setup {
+ destroy .foo
+} -body {
frame .foo
place .foo -x 0 -y 0
- set res [place configure .foo -x]
+ place configure .foo -x
+} -cleanup {
+ destroy .foo
+} -result {-x {} {} 0 0}
+test place-9.10 {PlaceObjCmd, forget errors} -setup {
destroy .foo
- set res
-} [list -x {} {} 0 0]
-test place-9.10 {PlaceObjCmd, forget errors} {
- catch {destroy .foo}
+} -body {
frame .foo
- set res [list [catch {place forget .foo bar} msg] $msg]
+ place forget .foo bar
+} -cleanup {
destroy .foo
- set res
-} [list 1 "wrong # args: should be \"place forget pathName\""]
-test place-9.11 {PlaceObjCmd, info errors} {
- catch {destroy .foo}
+} -returnCodes error -result {wrong # args: should be "place forget pathName"}
+test place-9.11 {PlaceObjCmd, info errors} -setup {
+ destroy .foo
+} -body {
frame .foo
- set res [list [catch {place info .foo bar} msg] $msg]
+ place info .foo bar
+} -cleanup {
+ destroy .foo
+} -returnCodes error -result {wrong # args: should be "place info pathName"}
+test place-9.12 {PlaceObjCmd, slaves errors} -setup {
destroy .foo
- set res
-} [list 1 "wrong # args: should be \"place info pathName\""]
-test place-9.12 {PlaceObjCmd, slaves errors} {
- catch {destroy .foo}
+} -body {
frame .foo
- set res [list [catch {place slaves .foo bar} msg] $msg]
+ place slaves .foo bar
+} -cleanup {
destroy .foo
- set res
-} [list 1 "wrong # args: should be \"place slaves pathName\""]
-
-test place-10.1 {ConfigureSlave} {
- catch {destroy .foo}
+} -returnCodes error -result {wrong # args: should be "place slaves pathName"}
+
+
+test place-10.1 {ConfigureSlave} -setup {
+ destroy .foo
+} -body {
frame .foo
- set res [list [catch {place .foo -badopt} msg] $msg]
+ place .foo -badopt
+} -cleanup {
destroy .foo
- set res
-} [list 1 "unknown option \"-badopt\""]
-test place-10.2 {ConfigureSlave} {
- catch {destroy .foo}
+} -returnCodes error -result {unknown option "-badopt"}
+test place-10.2 {ConfigureSlave} -setup {
+ destroy .foo
+} -body {
frame .foo
- set res [list [catch {place .foo -anchor} msg] $msg]
+ place .foo -anchor
+} -cleanup {
+ destroy .foo
+} -returnCodes error -result {value for "-anchor" missing}
+test place-10.3 {ConfigureSlave} -setup {
destroy .foo
- set res
-} [list 1 "value for \"-anchor\" missing"]
-test place-10.3 {ConfigureSlave} {
- catch {destroy .foo}
+} -body {
frame .foo
- set res [list [catch {place .foo -bordermode j} msg] $msg]
+ place .foo -bordermode j
+} -cleanup {
+ destroy .foo
+} -returnCodes error -result {bad bordermode "j": must be inside, outside, or ignore}
+test place-10.4 {ConfigureSlave} -setup {
destroy .foo
- set res
-} [list 1 "bad bordermode \"j\": must be inside, outside, or ignore"]
-test place-10.4 {ConfigureSlave} {
- catch {destroy .foo}
+} -body {
frame .foo
- set res [list [catch {place configure .foo -x 0 -y} msg] $msg]
+ place configure .foo -x 0 -y
+} -cleanup {
+ destroy .foo
+} -returnCodes error -result {value for "-y" missing}
+
+
+test place-11.1 {PlaceObjCmd, slaves command} -setup {
destroy .foo
- set res
-} [list 1 "value for \"-y\" missing"]
-
-test place-11.1 {PlaceObjCmd, slaves command} {
- catch {destroy .foo}
+} -body {
frame .foo
- set res [place slaves .foo]
+ place slaves .foo
+} -cleanup {
destroy .foo
- set res
-} {}
-test place-11.2 {PlaceObjCmd, slaves command} {
- catch {destroy .foo .bar}
+} -result {}
+test place-11.2 {PlaceObjCmd, slaves command} -setup {
+ destroy .foo .bar
+} -body {
frame .foo
frame .bar
place .bar -in .foo
- set res [place slaves .foo]
- destroy .foo
- destroy .bar
- set res
-} [list .bar]
+ place slaves .foo
+} -cleanup {
+ destroy .foo .bar
+} -result [list .bar]
+
-test place-12.1 {PlaceObjCmd, forget command} {
- catch {destroy .foo}
+test place-12.1 {PlaceObjCmd, forget command} -setup {
+ destroy .foo
+} -body {
frame .foo
place .foo -width 50 -height 50
update
@@ -362,11 +430,14 @@ test place-12.1 {PlaceObjCmd, forget command} {
place forget .foo
update
lappend res [winfo ismapped .foo]
+} -cleanup {
destroy .foo
- set res
-} [list 1 0]
+} -result {1 0}
+
-test place-13.1 {test respect for internalborder} {
+test place-13.1 {test respect for internalborder} -setup {
+ destroy .pack
+} -body {
toplevel .pack
wm geometry .pack 200x200
frame .pack.l -width 15 -height 10
@@ -379,11 +450,13 @@ test place-13.1 {test respect for internalborder} {
.pack.lf configure -labelanchor e -padx 3 -pady 5
update
lappend res [winfo geometry .pack.lf.f]
+} -cleanup {
destroy .pack
- set res
-} {196x188+2+10 177x186+5+7}
+} -result {196x188+2+10 177x186+5+7}
-test place-14.1 {memory leak testing} -setup {
+
+test place-14.1 {memory leak testing} -constraints memory -setup {
+ destroy .f
proc getbytes {} {
set lines [split [memory info] "\n"]
lindex [lindex $lines 3] 3
@@ -402,7 +475,7 @@ test place-14.1 {memory leak testing} -setup {
}
return $res
}
-} -constraints memory -body {
+} -body {
# Test all manners of forgetting a slave
frame .f
frame .f.f
@@ -418,14 +491,16 @@ test place-14.1 {memory leak testing} -setup {
frame .f
frame .f.f
}
-} -result {0 0 0} -cleanup {
+} -cleanup {
destroy .f
rename getbytes {}
rename stress {}
-}
+} -result {0 0 0}
-catch {destroy .t}
# cleanup
cleanupTests
return
+
+
+
diff --git a/tests/scale.test b/tests/scale.test
index 5a2a26d..6763848 100644
--- a/tests/scale.test
+++ b/tests/scale.test
@@ -6,9 +6,10 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: scale.test,v 1.16 2008/07/23 23:24:24 nijtmans Exp $
+# RCS: @(#) $Id: scale.test,v 1.17 2008/08/28 08:52:05 aniap Exp $
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
@@ -19,220 +20,497 @@ option add *Scale.borderWidth 2
option add *Scale.highlightThickness 2
option add *Scale.font {Helvetica -12 bold}
+# Widget used in 1.* tests
scale .s -from 100 -to 300
pack .s
update
-set i 1
-foreach test {
- {-activebackground #ff0000 #ff0000 non-existent
- {unknown color name "non-existent"}}
- {-background #ff0000 #ff0000 non-existent
- {unknown color name "non-existent"}}
- {-bd 4 4 badValue {bad screen distance "badValue"}}
- {-bigincrement 12.5 12.5 badValue
- {expected floating-point number but got "badValue"}}
- {-bg #ff0000 #ff0000 non-existent
- {unknown color name "non-existent"}}
- {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
- {-command "set x" {set x} {} {}}
- {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
- {-digits 5 5 badValue {expected integer but got "badValue"}}
- {-fg #00ff00 #00ff00 badValue {unknown color name "badValue"}}
- {-font fixed fixed {} {font "" doesn't exist}}
- {-foreground green green badValue {unknown color name "badValue"}}
- {-from -15.0 -15.0 badValue
- {expected floating-point number but got "badValue"}}
- {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}}
- {-highlightcolor #123456 #123456 non-existent
- {unknown color name "non-existent"}}
- {-highlightthickness 2 2 badValue {bad screen distance "badValue"}}
- {-label "Some text" {Some text} {} {}}
- {-length 130 130 badValue {bad screen distance "badValue"}}
- {-orient horizontal horizontal badValue
- {bad orient "badValue": must be horizontal or vertical}}
- {-orient horizontal horizontal {} {}}
- {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
- {-repeatdelay 14 14 bogus {expected integer but got "bogus"}}
- {-repeatinterval 14 14 bogus {expected integer but got "bogus"}}
- {-resolution 2.0 2.0 badValue
- {expected floating-point number but got "badValue"}}
- {-showvalue 0 0 badValue {expected boolean value but got "badValue"}}
- {-sliderlength 86 86 badValue {bad screen distance "badValue"}}
- {-sliderrelief raised raised badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
- {-state d disabled badValue
- {bad state "badValue": must be active, disabled, or normal}}
- {-state n normal {} {}}
- {-takefocus "any string" "any string" {} {}}
- {-tickinterval 4.3 4.0 badValue
- {expected floating-point number but got "badValue"}}
- {-to 14.9 15.0 badValue
- {expected floating-point number but got "badValue"}}
- {-troughcolor #ff0000 #ff0000 non-existent
- {unknown color name "non-existent"}}
- {-variable x x {} {}}
- {-width 32 32 badValue {bad screen distance "badValue"}}
-} {
- set name [lindex $test 0]
- test scale-1.$i {configuration options} {
- .s configure $name [lindex $test 1]
- lindex [.s configure $name] 4
- } [lindex $test 2]
- incr i
- if {[lindex $test 3] ne ""} {
- test scale-1.$i {configuration options} {
- list [catch {.s configure $name [lindex $test 3]} msg] $msg
- } [list 1 [lindex $test 4]]
- }
- .s configure $name [lindex [.s configure $name] 3]
- incr i
-}
+
+test scale-1.1 {configuration options} -body {
+ .s configure -activebackground #ff0000
+ .s cget -activebackground
+} -cleanup {
+ .s configure -activebackground [lindex [.s configure -activebackground] 3]
+} -result {#ff0000}
+test scale-1.2 {configuration options} -body {
+ .s configure -activebackground non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test scale-1.3 {configuration options} -body {
+ .s configure -background #ff0000
+ .s cget -background
+} -cleanup {
+ .s configure -background [lindex [.s configure -background] 3]
+} -result {#ff0000}
+test scale-1.4 {configuration options} -body {
+ .s configure -background non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test scale-1.5 {configuration options} -body {
+ .s configure -bd 4
+ .s cget -bd
+} -cleanup {
+ .s configure -bd [lindex [.s configure -bd] 3]
+} -result {4}
+test scale-1.6 {configuration options} -body {
+ .s configure -bd badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test scale-1.7 {configuration options} -body {
+ .s configure -bigincrement 12.5
+ .s cget -bigincrement
+} -cleanup {
+ .s configure -bigincrement [lindex [.s configure -bigincrement] 3]
+} -result {12.5}
+test scale-1.8 {configuration options} -body {
+ .s configure -bigincrement badValue
+} -returnCodes error -result {expected floating-point number but got "badValue"}
+test scale-1.9 {configuration options} -body {
+ .s configure -bg #ff0000
+ .s cget -bg
+} -cleanup {
+ .s configure -bg [lindex [.s configure -bg] 3]
+} -result {#ff0000}
+test scale-1.10 {configuration options} -body {
+ .s configure -bg non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test scale-1.11 {configuration options} -body {
+ .s configure -borderwidth 1.3
+ .s cget -borderwidth
+} -cleanup {
+ .s configure -borderwidth [lindex [.s configure -borderwidth] 3]
+} -result {1}
+test scale-1.12 {configuration options} -body {
+ .s configure -borderwidth badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test scale-1.13 {configuration options} -body {
+ .s configure -command {set x}
+ .s cget -command
+} -cleanup {
+ .s configure -command [lindex [.s configure -command] 3]
+} -result {set x}
+test scale-1.15 {configuration options} -body {
+ .s configure -cursor arrow
+ .s cget -cursor
+} -cleanup {
+ .s configure -cursor [lindex [.s configure -cursor] 3]
+} -result {arrow}
+test scale-1.16 {configuration options} -body {
+ .s configure -cursor badValue
+} -returnCodes error -result {bad cursor spec "badValue"}
+test scale-1.17 {configuration options} -body {
+ .s configure -digits 5
+ .s cget -digits
+} -cleanup {
+ .s configure -digits [lindex [.s configure -digits] 3]
+} -result {5}
+test scale-1.18 {configuration options} -body {
+ .s configure -digits badValue
+} -returnCodes error -result {expected integer but got "badValue"}
+test scale-1.19 {configuration options} -body {
+ .s configure -fg #00ff00
+ .s cget -fg
+} -cleanup {
+ .s configure -fg [lindex [.s configure -fg] 3]
+} -result {#00ff00}
+test scale-1.20 {configuration options} -body {
+ .s configure -fg badValue
+} -returnCodes error -result {unknown color name "badValue"}
+test scale-1.21 {configuration options} -body {
+ .s configure -font fixed
+ .s cget -font
+} -cleanup {
+ .s configure -font [lindex [.s configure -font] 3]
+} -result {fixed}
+test scale-1.23 {configuration options} -body {
+ .s configure -foreground green
+ .s cget -foreground
+} -cleanup {
+ .s configure -foreground [lindex [.s configure -foreground] 3]
+} -result {green}
+test scale-1.24 {configuration options} -body {
+ .s configure -foreground badValue
+} -returnCodes error -result {unknown color name "badValue"}
+test scale-1.25 {configuration options} -body {
+ .s configure -from -15.0
+ .s cget -from
+} -cleanup {
+ .s configure -from [lindex [.s configure -from] 3]
+} -result {-15.0}
+test scale-1.26 {configuration options} -body {
+ .s configure -from badValue
+} -returnCodes error -result {expected floating-point number but got "badValue"}
+test scale-1.27 {configuration options} -body {
+ .s configure -highlightbackground #112233
+ .s cget -highlightbackground
+} -cleanup {
+ .s configure -highlightbackground [lindex [.s configure -highlightbackground] 3]
+} -result {#112233}
+test scale-1.28 {configuration options} -body {
+ .s configure -highlightbackground ugly
+} -returnCodes error -result {unknown color name "ugly"}
+test scale-1.29 {configuration options} -body {
+ .s configure -highlightcolor #123456
+ .s cget -highlightcolor
+} -cleanup {
+ .s configure -highlightcolor [lindex [.s configure -highlightcolor] 3]
+} -result {#123456}
+test scale-1.30 {configuration options} -body {
+ .s configure -highlightcolor non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test scale-1.31 {configuration options} -body {
+ .s configure -highlightthickness 2
+ .s cget -highlightthickness
+} -cleanup {
+ .s configure -highlightthickness [lindex [.s configure -highlightthickness] 3]
+} -result {2}
+test scale-1.32 {configuration options} -body {
+ .s configure -highlightthickness badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test scale-1.33 {configuration options} -body {
+ .s configure -label {Some text}
+ .s cget -label
+} -cleanup {
+ .s configure -label [lindex [.s configure -label] 3]
+} -result {Some text}
+test scale-1.35 {configuration options} -body {
+ .s configure -length 130
+ .s cget -length
+} -cleanup {
+ .s configure -length [lindex [.s configure -length] 3]
+} -result {130}
+test scale-1.36 {configuration options} -body {
+ .s configure -length badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test scale-1.37 {configuration options} -body {
+ .s configure -orient horizontal
+ .s cget -orient
+} -cleanup {
+ .s configure -orient [lindex [.s configure -orient] 3]
+} -result {horizontal}
+test scale-1.38 {configuration options} -body {
+ .s configure -orient badValue
+} -returnCodes error -result {bad orient "badValue": must be horizontal or vertical}
+test scale-1.39 {configuration options} -body {
+ .s configure -orient horizontal
+ .s cget -orient
+} -cleanup {
+ .s configure -orient [lindex [.s configure -orient] 3]
+} -result {horizontal}
+test scale-1.41 {configuration options} -body {
+ .s configure -relief ridge
+ .s cget -relief
+} -cleanup {
+ .s configure -relief [lindex [.s configure -relief] 3]
+} -result {ridge}
+test scale-1.42 {configuration options} -body {
+ .s configure -relief badValue
+} -returnCodes error -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}
+test scale-1.43 {configuration options} -body {
+ .s configure -repeatdelay 14
+ .s cget -repeatdelay
+} -cleanup {
+ .s configure -repeatdelay [lindex [.s configure -repeatdelay] 3]
+} -result {14}
+test scale-1.44 {configuration options} -body {
+ .s configure -repeatdelay bogus
+} -returnCodes error -result {expected integer but got "bogus"}
+test scale-1.45 {configuration options} -body {
+ .s configure -repeatinterval 14
+ .s cget -repeatinterval
+} -cleanup {
+ .s configure -repeatinterval [lindex [.s configure -repeatinterval] 3]
+} -result {14}
+test scale-1.46 {configuration options} -body {
+ .s configure -repeatinterval bogus
+} -returnCodes error -result {expected integer but got "bogus"}
+test scale-1.47 {configuration options} -body {
+ .s configure -resolution 2.0
+ .s cget -resolution
+} -cleanup {
+ .s configure -resolution [lindex [.s configure -resolution] 3]
+} -result {2.0}
+test scale-1.48 {configuration options} -body {
+ .s configure -resolution badValue
+} -returnCodes error -result {expected floating-point number but got "badValue"}
+test scale-1.49 {configuration options} -body {
+ .s configure -showvalue 0
+ .s cget -showvalue
+} -cleanup {
+ .s configure -showvalue [lindex [.s configure -showvalue] 3]
+} -result {0}
+test scale-1.50 {configuration options} -body {
+ .s configure -showvalue badValue
+} -returnCodes error -result {expected boolean value but got "badValue"}
+test scale-1.51 {configuration options} -body {
+ .s configure -sliderlength 86
+ .s cget -sliderlength
+} -cleanup {
+ .s configure -sliderlength [lindex [.s configure -sliderlength] 3]
+} -result {86}
+test scale-1.52 {configuration options} -body {
+ .s configure -sliderlength badValue
+} -returnCodes error -result {bad screen distance "badValue"}
+test scale-1.53 {configuration options} -body {
+ .s configure -sliderrelief raised
+ .s cget -sliderrelief
+} -cleanup {
+ .s configure -sliderrelief [lindex [.s configure -sliderrelief] 3]
+} -result {raised}
+test scale-1.54 {configuration options} -body {
+ .s configure -sliderrelief badValue
+} -returnCodes error -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}
+test scale-1.55 {configuration options} -body {
+ .s configure -state d
+ .s cget -state
+} -cleanup {
+ .s configure -state [lindex [.s configure -state] 3]
+} -result {disabled}
+test scale-1.56 {configuration options} -body {
+ .s configure -state badValue
+} -returnCodes error -result {bad state "badValue": must be active, disabled, or normal}
+test scale-1.57 {configuration options} -body {
+ .s configure -state n
+ .s cget -state
+} -cleanup {
+ .s configure -state [lindex [.s configure -state] 3]
+} -result {normal}
+test scale-1.59 {configuration options} -body {
+ .s configure -takefocus {any string}
+ .s cget -takefocus
+} -cleanup {
+ .s configure -takefocus [lindex [.s configure -takefocus] 3]
+} -result {any string}
+test scale-1.61 {configuration options} -body {
+ .s configure -tickinterval 4.3
+ .s cget -tickinterval
+} -cleanup {
+ .s configure -tickinterval [lindex [.s configure -tickinterval] 3]
+} -result {4.0}
+test scale-1.62 {configuration options} -body {
+ .s configure -tickinterval badValue
+} -returnCodes error -result {expected floating-point number but got "badValue"}
+test scale-1.63 {configuration options} -body {
+ .s configure -to 14.9
+ .s cget -to
+} -cleanup {
+ .s configure -to [lindex [.s configure -to] 3]
+} -result {15.0}
+test scale-1.64 {configuration options} -body {
+ .s configure -to badValue
+} -returnCodes error -result {expected floating-point number but got "badValue"}
+test scale-1.65 {configuration options} -body {
+ .s configure -troughcolor #ff0000
+ .s cget -troughcolor
+} -cleanup {
+ .s configure -troughcolor [lindex [.s configure -troughcolor] 3]
+} -result {#ff0000}
+test scale-1.66 {configuration options} -body {
+ .s configure -troughcolor non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test scale-1.67 {configuration options} -body {
+ .s configure -variable x
+ .s cget -variable
+} -cleanup {
+ .s configure -variable [lindex [.s configure -variable] 3]
+} -result {x}
+test scale-1.69 {configuration options} -body {
+ .s configure -width 32
+ .s cget -width
+} -cleanup {
+ .s configure -width [lindex [.s configure -width] 3]
+} -result {32}
+test scale-1.70 {configuration options} -body {
+ .s configure -width badValue
+} -returnCodes error -result {bad screen distance "badValue"}
destroy .s
-test scale-2.1 {Tk_ScaleCmd procedure} {
- list [catch {scale} msg] $msg
-} {1 {wrong # args: should be "scale pathName ?-option value ...?"}}
-test scale-2.2 {Tk_ScaleCmd procedure} {
- list [catch {scale foo} msg] $msg [winfo child .]
-} {1 {bad window path name "foo"} {}}
-test scale-2.3 {Tk_ScaleCmd procedure} {
- list [catch {scale .s -gorp dumb} msg] $msg [winfo child .]
-} {1 {unknown option "-gorp"} {}}
+test scale-2.1 {Tk_ScaleCmd procedure} -body {
+ scale
+} -returnCodes error -result {wrong # args: should be "scale pathName ?-option value ...?"}
+test scale-2.2 {Tk_ScaleCmd procedure} -body {
+ scale foo
+} -returnCodes error -result {bad window path name "foo"}
+test scale-2.3 {Tk_ScaleCmd procedure} -body {
+ catch {scale foo}
+ winfo child .
+} -result {}
+test scale-2.4 {Tk_ScaleCmd procedure} -body {
+ scale .s -gorp dumb
+} -returnCodes error -result {unknown option "-gorp"}
+test scale-2.5 {Tk_ScaleCmd procedure} -body {
+ catch {scale .s -gorp dumb}
+ winfo child .
+} -result {}
+
+
+# Widget used in 3.* tests
+destroy .s
scale .s -from 100 -to 200
pack .s
update idletasks
-test scale-3.1 {ScaleWidgetCmd procedure} {
- list [catch {.s} msg] $msg
-} {1 {wrong # args: should be ".s option ?arg ...?"}}
-test scale-3.2 {ScaleWidgetCmd procedure, cget option} {
- list [catch {.s cget} msg] $msg
-} {1 {wrong # args: should be ".s cget option"}}
-test scale-3.3 {ScaleWidgetCmd procedure, cget option} {
- list [catch {.s cget a b} msg] $msg
-} {1 {wrong # args: should be ".s cget option"}}
-test scale-3.4 {ScaleWidgetCmd procedure, cget option} {
- list [catch {.s cget -gorp} msg] $msg
-} {1 {unknown option "-gorp"}}
-test scale-3.5 {ScaleWidgetCmd procedure, cget option} {
+test scale-3.1 {ScaleWidgetCmd procedure} -body {
+ .s
+} -returnCodes error -result {wrong # args: should be ".s option ?arg ...?"}
+test scale-3.2 {ScaleWidgetCmd procedure, cget option} -body {
+ .s cget
+} -returnCodes error -result {wrong # args: should be ".s cget option"}
+test scale-3.3 {ScaleWidgetCmd procedure, cget option} -body {
+ .s cget a b
+} -returnCodes error -result {wrong # args: should be ".s cget option"}
+test scale-3.4 {ScaleWidgetCmd procedure, cget option} -body {
+ .s cget -gorp
+} -returnCodes error -result {unknown option "-gorp"}
+test scale-3.5 {ScaleWidgetCmd procedure, cget option} -body {
+ .s configure -highlightthickness 2
.s cget -highlightthickness
-} {2}
-test scale-3.6 {ScaleWidgetCmd procedure, configure option} {
+} -result {2}
+test scale-3.6 {ScaleWidgetCmd procedure, configure option} -body {
list [llength [.s configure]] [lindex [.s configure] 6]
-} {33 {-command command Command {} {}}}
-test scale-3.7 {ScaleWidgetCmd procedure, configure option} {
- list [catch {.s configure -foo} msg] $msg
-} {1 {unknown option "-foo"}}
-test scale-3.8 {ScaleWidgetCmd procedure, configure option} {
- list [catch {.s configure -borderwidth 2 -bg} msg] $msg
-} {1 {value for "-bg" missing}}
-test scale-3.9 {ScaleWidgetCmd procedure, coords option} {
- list [catch {.s coords a b} msg] $msg
-} {1 {wrong # args: should be ".s coords ?value?"}}
-test scale-3.10 {ScaleWidgetCmd procedure, coords option} {
- list [catch {.s coords bad} msg] $msg
-} {1 {expected floating-point number but got "bad"}}
-test scale-3.11 {ScaleWidgetCmd procedure} {fonts} {
+} -result {33 {-command command Command {} {}}}
+test scale-3.7 {ScaleWidgetCmd procedure, configure option} -body {
+ .s configure -foo
+} -returnCodes error -result {unknown option "-foo"}
+test scale-3.8 {ScaleWidgetCmd procedure, configure option} -body {
+ .s configure -borderwidth 2 -bg
+} -returnCodes error -result {value for "-bg" missing}
+test scale-3.9 {ScaleWidgetCmd procedure, coords option} -body {
+ .s coords a b
+} -returnCodes error -result {wrong # args: should be ".s coords ?value?"}
+test scale-3.10 {ScaleWidgetCmd procedure, coords option} -body {
+ .s coords bad
+} -returnCodes error -result {expected floating-point number but got "bad"}
+test scale-3.11 {ScaleWidgetCmd procedure} -constraints {
+ fonts
+} -body {
+ .s configure -from 100 -to 200
+ update idletasks
.s set 120
.s coords
-} {38 34}
-test scale-3.12 {ScaleWidgetCmd procedure, coords option} {fonts} {
- .s configure -orient horizontal
- update
+} -result {38 34}
+test scale-3.12 {ScaleWidgetCmd procedure, coords option} -constraints {
+ fonts
+} -body {
+ .s configure -from 100 -to 200 -orient horizontal
+ update idletasks
.s set 120
.s coords
-} {34 31}
-.s configure -orient vertical
-update
-test scale-3.13 {ScaleWidgetCmd procedure, get option} {
- list [catch {.s get a} msg] $msg
-} {1 {wrong # args: should be ".s get ?x y?"}}
-test scale-3.14 {ScaleWidgetCmd procedure, get option} {
- list [catch {.s get a b c} msg] $msg
-} {1 {wrong # args: should be ".s get ?x y?"}}
-test scale-3.15 {ScaleWidgetCmd procedure, get option} {
- list [catch {.s get a 11} msg] $msg
-} {1 {expected integer but got "a"}}
-test scale-3.16 {ScaleWidgetCmd procedure, get option} {
- list [catch {.s get 12 b} msg] $msg
-} {1 {expected integer but got "b"}}
-test scale-3.17 {ScaleWidgetCmd procedure, get option} {
+} -result {34 31}
+test scale-3.13 {ScaleWidgetCmd procedure, get option} -body {
+ .s configure -orient vertical
+ update
+ .s get a
+} -returnCodes error -result {wrong # args: should be ".s get ?x y?"}
+test scale-3.14 {ScaleWidgetCmd procedure, get option} -body {
+ .s configure -orient vertical
+ update
+ .s get a b c
+} -returnCodes error -result {wrong # args: should be ".s get ?x y?"}
+test scale-3.15 {ScaleWidgetCmd procedure, get option} -body {
+ .s configure -orient vertical
+ update
+ .s get a 11
+} -returnCodes error -result {expected integer but got "a"}
+test scale-3.16 {ScaleWidgetCmd procedure, get option} -body {
+ .s configure -orient vertical
+ update
+ .s get 12 b
+} -returnCodes error -result {expected integer but got "b"}
+test scale-3.17 {ScaleWidgetCmd procedure, get option} -body {
+ .s configure -orient vertical
+ update
.s set 133
.s get
-} 133
-test scale-3.18 {ScaleWidgetCmd procedure, get option} {
- .s configure -resolution 0.5
+} -result 133
+test scale-3.18 {ScaleWidgetCmd procedure, get option} -body {
+ .s configure -orient vertical -resolution 0.5
+ update
.s set 150
.s get 37 34
-} 119.5
+} -result {119.5}
.s configure -resolution 1
-test scale-3.19 {ScaleWidgetCmd procedure, identify option} {
- list [catch {.s identify} msg] $msg
-} {1 {wrong # args: should be ".s identify x y"}}
-test scale-3.20 {ScaleWidgetCmd procedure, identify option} {
- list [catch {.s identify 1 2 3} msg] $msg
-} {1 {wrong # args: should be ".s identify x y"}}
-test scale-3.21 {ScaleWidgetCmd procedure, identify option} {
- list [catch {.s identify boo 16} msg] $msg
-} {1 {expected integer but got "boo"}}
-test scale-3.22 {ScaleWidgetCmd procedure, identify option} {
- list [catch {.s identify 17 bad} msg] $msg
-} {1 {expected integer but got "bad"}}
-test scale-3.23 {ScaleWidgetCmd procedure, identify option} {fonts} {
+test scale-3.19 {ScaleWidgetCmd procedure, identify option} -body {
+ .s identify
+} -returnCodes error -result {wrong # args: should be ".s identify x y"}
+test scale-3.20 {ScaleWidgetCmd procedure, identify option} -body {
+ .s identify 1 2 3
+} -returnCodes error -result {wrong # args: should be ".s identify x y"}
+test scale-3.21 {ScaleWidgetCmd procedure, identify option} -body {
+ .s identify boo 16
+} -returnCodes error -result {expected integer but got "boo"}
+test scale-3.22 {ScaleWidgetCmd procedure, identify option} -body {
+ .s identify 17 bad
+} -returnCodes error -result {expected integer but got "bad"}
+test scale-3.23 {ScaleWidgetCmd procedure, identify option} -constraints {
+ fonts
+} -body {
+ .s configure -from 100 -to 200 -orient vertical -resolution 1
+ update
.s set 120
list [.s identify 35 10] [.s identify 35 30] [.s identify 35 80] [.s identify 5 80]
-} {trough1 slider trough2 {}}
-test scale-3.24 {ScaleWidgetCmd procedure, set option} {
- list [catch {.s set} msg] $msg
-} {1 {wrong # args: should be ".s set value"}}
-test scale-3.25 {ScaleWidgetCmd procedure, set option} {
- list [catch {.s set a b} msg] $msg
-} {1 {wrong # args: should be ".s set value"}}
-test scale-3.26 {ScaleWidgetCmd procedure, set option} {
- list [catch {.s set bad} msg] $msg
-} {1 {expected floating-point number but got "bad"}}
-test scale-3.27 {ScaleWidgetCmd procedure, set option} {
+} -result {trough1 slider trough2 {}}
+test scale-3.24 {ScaleWidgetCmd procedure, set option} -body {
+ .s set
+} -returnCodes error -result {wrong # args: should be ".s set value"}
+test scale-3.25 {ScaleWidgetCmd procedure, set option} -body {
+ .s set a b
+} -returnCodes error -result {wrong # args: should be ".s set value"}
+test scale-3.26 {ScaleWidgetCmd procedure, set option} -body {
+ .s set bad
+} -returnCodes error -result {expected floating-point number but got "bad"}
+test scale-3.27 {ScaleWidgetCmd procedure, set option} -body {
+ .s configure -from 100 -to 200 -orient vertical -resolution 0.5
+ update
.s set 142
-} {}
-test scale-3.28 {ScaleWidgetCmd procedure, set option} {
+} -result {}
+test scale-3.28 {ScaleWidgetCmd procedure, set option} -body {
+ .s configure -from 100 -to 200 -orient vertical -resolution 1
+ update
.s set 118
.s configure -state disabled
.s set 181
.s configure -state normal
.s get
-} {118}
-test scale-3.29 {ScaleWidgetCmd procedure} {
- list [catch {.s dumb} msg] $msg
-} {1 {bad option "dumb": must be cget, configure, coords, get, identify, or set}}
-test scale-3.30 {ScaleWidgetCmd procedure} {
- list [catch {.s c} msg] $msg
-} {1 {ambiguous option "c": must be cget, configure, coords, get, identify, or set}}
-test scale-3.31 {ScaleWidgetCmd procedure} {
- list [catch {.s co} msg] $msg
-} {1 {ambiguous option "co": must be cget, configure, coords, get, identify, or set}}
-test scale-3.32 {ScaleWidgetCmd procedure, Tk_Preserve} {
+} -result {118}
+test scale-3.29 {ScaleWidgetCmd procedure} -body {
+ .s dumb
+} -returnCodes error -result {bad option "dumb": must be cget, configure, coords, get, identify, or set}
+test scale-3.30 {ScaleWidgetCmd procedure} -body {
+ .s c
+} -returnCodes error -result {ambiguous option "c": must be cget, configure, coords, get, identify, or set}
+test scale-3.31 {ScaleWidgetCmd procedure} -body {
+ .s co
+} -returnCodes error -result {ambiguous option "co": must be cget, configure, coords, get, identify, or set}
+destroy .s
+
+test scale-3.32 {ScaleWidgetCmd procedure, Tk_Preserve} -setup {
+ destroy .s
+} -body {
proc kill args {
- destroy .s
+ destroy .s
}
- catch {destroy .s}
scale .s -variable x -from 0 -to 100 -orient horizontal
pack .s
update
.s configure -command kill
.s set 55
-} {}
+} -cleanup {
+ destroy .s
+} -result {}
+
-test scale-4.1 {DestroyScale procedure} {
- catch {destroy .s}
+test scale-4.1 {DestroyScale procedure} -setup {
+ deleteWindows
+} -body {
set x 50
scale .s -variable x -from 0 -to 100 -orient horizontal
pack .s
update
destroy .s
list [catch {set x foo} msg] $msg $x
-} {0 foo foo}
+} -result {0 foo foo}
+
-test scale-5.1 {ConfigureScale procedure} {
- catch {destroy .s}
+test scale-5.1 {ConfigureScale procedure} -setup {
+ deleteWindows
+} -body {
set x 66
set y 77
scale .s -variable x -from 0 -to 100
@@ -240,14 +518,20 @@ test scale-5.1 {ConfigureScale procedure} {
update
.s configure -variable y
list [catch {set x foo} msg] $msg $x [.s get]
-} {0 foo foo 77}
-test scale-5.2 {ConfigureScale procedure} {
- catch {destroy .s}
+} -cleanup {
+ deleteWindows
+} -result {0 foo foo 77}
+test scale-5.2 {ConfigureScale procedure} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 100
- list [catch {.s configure -foo bar} msg] $msg
-} {1 {unknown option "-foo"}}
-test scale-5.3 {ConfigureScale procedure} {
- catch {destroy .s}
+ .s configure -foo bar
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {unknown option "-foo"}
+test scale-5.3 {ConfigureScale procedure} -setup {
+ deleteWindows
+} -body {
catch {unset x}
scale .s -from 0 -to 100 -variable x
set result $x
@@ -257,349 +541,475 @@ test scale-5.3 {ConfigureScale procedure} {
.s set 3
lappend result $x
unset x
- lappend result [catch {set x} msg] $msg
-} {0 0 92 3 0 3}
-test scale-5.4 {ConfigureScale procedure} {
- catch {destroy .s}
+ lappend result [set x]
+} -cleanup {
+ deleteWindows
+} -result {0 0 92 3 3}
+test scale-5.4 {ConfigureScale procedure} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 100
- list [catch {.s configure -orient dumb} msg] $msg
-} {1 {bad orient "dumb": must be horizontal or vertical}}
-test scale-5.5 {ConfigureScale procedure} {
- catch {destroy .s}
+ .s configure -orient dumb
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {bad orient "dumb": must be horizontal or vertical}
+test scale-5.5 {ConfigureScale procedure} -setup {
+ deleteWindows
+} -body {
scale .s -from 1.11 -to 1.89 -resolution .1 -tickinterval .76
list [format %.1f [.s cget -from]] [format %.1f [.s cget -to]] \
- [format %.1f [.s cget -tickinterval]]
-} {1.1 1.9 0.8}
-test scale-5.6 {ConfigureScale procedure} {
- catch {destroy .s}
+ [format %.1f [.s cget -tickinterval]]
+} -cleanup {
+ deleteWindows
+} -result {1.1 1.9 0.8}
+test scale-5.6 {ConfigureScale procedure} -setup {
+ deleteWindows
+} -body {
scale .s -from 1 -to 10 -tickinterval -2
pack .s
set result [lindex [.s configure -tickinterval] 4]
.s configure -from 10 -to 1 -tickinterval 2
lappend result [lindex [.s configure -tickinterval] 4]
-} {2.0 -2.0}
-test scale-5.7 {ConfigureScale procedure} {
- catch {destroy .s}
- list [catch {scale .s -from 0 -to 100 -state bogus} msg] $msg
-} {1 {bad state "bogus": must be active, disabled, or normal}}
+} -cleanup {
+ deleteWindows
+} -result {2.0 -2.0}
+test scale-5.7 {ConfigureScale procedure} -setup {
+ deleteWindows
+} -body {
+ scale .s -from 0 -to 100 -state bogus
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {bad state "bogus": must be active, disabled, or normal}
+
-catch {destroy .s}
+# Widget used in 6.* tests
+destroy .s
scale .s -orient horizontal -length 200
pack .s
-test scale-6.1 {ComputeFormat procedure} {
+test scale-6.1 {ComputeFormat procedure} -body {
.s configure -from 10 -to 100 -resolution 10
.s set 49.3
.s get
-} {50}
-test scale-6.2 {ComputeFormat procedure} {
+} -result {50}
+test scale-6.2 {ComputeFormat procedure} -body {
.s configure -from 100 -to 1000 -resolution 100
.s set 493
.s get
-} {500}
-test scale-6.3 {ComputeFormat procedure} {
+} -result {500}
+test scale-6.3 {ComputeFormat procedure} -body {
.s configure -from 1000 -to 10000 -resolution 1000
.s set 4930
.s get
-} {5000}
-test scale-6.4 {ComputeFormat procedure} {
+} -result {5000}
+test scale-6.4 {ComputeFormat procedure} -body {
.s configure -from 10000 -to 100000 -resolution 10000
.s set 49000
.s get
-} {50000}
-test scale-6.5 {ComputeFormat procedure} {
+} -result {50000}
+test scale-6.5 {ComputeFormat procedure} -body {
.s configure -from 100000 -to 1000000 -resolution 100000
.s set 493000
.s get
-} {500000}
-test scale-6.6 {ComputeFormat procedure} {nonPortable} {
+} -result {500000}
+test scale-6.6 {ComputeFormat procedure} -constraints {
+ nonPortable
+} -body {
# This test is non-portable because some platforms format the
# result as 5e+06.
-
.s configure -from 1000000 -to 10000000 -resolution 1000000
.s set 4930000
.s get
-} {5000000}
-test scale-6.7 {ComputeFormat procedure} {
+} -result {5000000}
+test scale-6.7 {ComputeFormat procedure} -body {
.s configure -from 1000000000 -to 10000000000 -resolution 1000000000
.s set 4930000000
expr {[.s get] == 5.0e+09}
-} 1
-test scale-6.8 {ComputeFormat procedure} {
+} -result 1
+test scale-6.8 {ComputeFormat procedure} -body {
.s configure -from .1 -to 1 -resolution .1
.s set .6
.s get
-} {0.6}
-test scale-6.9 {ComputeFormat procedure} {
+} -result {0.6}
+test scale-6.9 {ComputeFormat procedure} -body {
.s configure -from .01 -to .1 -resolution .01
.s set .06
.s get
-} {0.06}
-test scale-6.10 {ComputeFormat procedure} {
+} -result {0.06}
+test scale-6.10 {ComputeFormat procedure} -body {
.s configure -from .001 -to .01 -resolution .001
.s set .006
.s get
-} {0.006}
-test scale-6.11 {ComputeFormat procedure} {
+} -result {0.006}
+test scale-6.11 {ComputeFormat procedure} -body {
.s configure -from .0001 -to .001 -resolution .0001
.s set .0006
.s get
-} {0.0006}
-test scale-6.12 {ComputeFormat procedure} {
+} -result {0.0006}
+test scale-6.12 {ComputeFormat procedure} -body {
.s configure -from .00001 -to .0001 -resolution .00001
.s set .00006
.s get
-} {0.00006}
-test scale-6.13 {ComputeFormat procedure} {
+} -result {0.00006}
+test scale-6.13 {ComputeFormat procedure} -body {
.s configure -from .000001 -to .00001 -resolution .000001
.s set .000006
expr {[.s get] == 6.0e-06}
-} {1}
-test scale-6.14 {ComputeFormat procedure} {
+} -result {1}
+test scale-6.14 {ComputeFormat procedure} -body {
.s configure -to .00001 -from .0001 -resolution .00001
.s set .00006
.s get
-} {0.00006}
-test scale-6.15 {ComputeFormat procedure} {
+} -result {0.00006}
+test scale-6.15 {ComputeFormat procedure} -body {
.s configure -to .000001 -from .00001 -resolution .000001
.s set .000006
expr {[.s get] == 6.0e-06}
-} {1}
-test scale-6.16 {ComputeFormat procedure} {
+} -result {1}
+test scale-6.16 {ComputeFormat procedure} -body {
.s configure -from .00001 -to .0001 -resolution .00001 -digits 1
.s set .00006
expr {[.s get] == 6e-05}
-} {1}
-test scale-6.17 {ComputeFormat procedure} {
+} -result {1}
+test scale-6.17 {ComputeFormat procedure} -body {
.s configure -from 10000000 -to 100000000 -resolution 10000000 -digits 3
.s set 49300000
.s get
-} {50000000}
-test scale-6.18 {ComputeFormat procedure} {
+} -result {50000000}
+test scale-6.18 {ComputeFormat procedure} -body {
.s configure -length 200 -from 0 -to 10 -resolution 0 -digits 0
.s set .111111111
.s get
-} {0.11}
-test scale-6.19 {ComputeFormat procedure} {
+} -result {0.11}
+test scale-6.19 {ComputeFormat procedure} -body {
.s configure -length 200 -from 1000 -to 1002 -resolution 0 -digits 0
.s set 1001.23456789
.s get
-} {1001.23}
-test scale-6.20 {ComputeFormat procedure} {
+} -result {1001.23}
+test scale-6.20 {ComputeFormat procedure} -body {
.s configure -length 200 -from 1000 -to 1001.8 -resolution 0 -digits 0
.s set 1001.23456789
.s get
-} {1001.235}
+} -result {1001.235}
+destroy .s
-test scale-7.1 {ComputeScaleGeometry procedure} {nonPortable fonts} {
- catch {destroy .s}
+
+test scale-7.1 {ComputeScaleGeometry procedure} -constraints {
+ nonPortable fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 10 -label "Short" -orient vertical -length 5i
pack .s
update
list [winfo reqwidth .s] [winfo reqheight .s]
-} {88 458}
-test scale-7.2 {ComputeScaleGeometry procedure} {fonts} {
- catch {destroy .s}
+} -cleanup {
+ deleteWindows
+} -result {88 458}
+test scale-7.2 {ComputeScaleGeometry procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 1000 -label "Long string" -orient vertical -tick 200
pack .s
update
list [winfo reqwidth .s] [winfo reqheight .s]
-} {168 108}
-test scale-7.3 {ComputeScaleGeometry procedure} {fonts} {
- catch {destroy .s}
+} -cleanup {
+ deleteWindows
+} -result {168 108}
+test scale-7.3 {ComputeScaleGeometry procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 1000 -orient vertical -showvalue 0 -width 10 \
- -sliderlength 10
+ -sliderlength 10
pack .s
update
list [winfo reqwidth .s] [winfo reqheight .s]
-} {22 108}
-test scale-7.4 {ComputeScaleGeometry procedure} {fonts} {
- catch {destroy .s}
+} -cleanup {
+ deleteWindows
+} -result {22 108}
+test scale-7.4 {ComputeScaleGeometry procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 1000 -orient vertical -showvalue 0 -bd 5 \
- -relief sunken
+ -relief sunken
pack .s
update
list [winfo reqwidth .s] [winfo reqheight .s]
-} {39 114}
-test scale-7.5 {ComputeScaleGeometry procedure} {nonPortable fonts} {
- catch {destroy .s}
+} -cleanup {
+ deleteWindows
+} -result {39 114}
+test scale-7.5 {ComputeScaleGeometry procedure} -constraints {
+ nonPortable fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 10 -label "Short" -orient horizontal -length 5i
pack .s
update
list [winfo reqwidth .s] [winfo reqheight .s]
-} {458 61}
-test scale-7.6 {ComputeScaleGeometry procedure} {fonts} {
- catch {destroy .s}
+} -cleanup {
+ deleteWindows
+} -result {458 61}
+test scale-7.6 {ComputeScaleGeometry procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 1000 -label "Long string" -orient horizontal \
- -tick 500
+ -tick 500
pack .s
update
list [winfo reqwidth .s] [winfo reqheight .s]
-} {108 79}
-test scale-7.7 {ComputeScaleGeometry procedure} {fonts} {
- catch {destroy .s}
+} -cleanup {
+ deleteWindows
+} -result {108 79}
+test scale-7.7 {ComputeScaleGeometry procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 1000 -orient horizontal -showvalue 0
pack .s
update
list [winfo reqwidth .s] [winfo reqheight .s]
-} {108 27}
-test scale-7.8 {ComputeScaleGeometry procedure} {
- catch {destroy .s}
+} -cleanup {
+ deleteWindows
+} -result {108 27}
+test scale-7.8 {ComputeScaleGeometry procedure} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 1000 -orient horizontal -showvalue 0 -bd 5 \
- -relief raised -highlightthickness 2
+ -relief raised -highlightthickness 2
pack .s
update
list [winfo reqwidth .s] [winfo reqheight .s]
-} {114 39}
+} -cleanup {
+ deleteWindows
+} -result {114 39}
+
-test scale-8.1 {ScaleElement procedure} {fonts} {
- catch {destroy .s}
+test scale-8.1 {ScaleElement procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 100 -orient vertical -bd 1 -tick 20 -length 300
pack .s
.s set 30
update
list [.s identify 53 52] [.s identify 54 52] [.s identify 70 52] \
- [.s identify 71 52]
-} {{} trough1 trough1 {}}
-test scale-8.2 {ScaleElement procedure} {fonts} {
- catch {destroy .s}
+ [.s identify 71 52]
+} -cleanup {
+ deleteWindows
+} -result {{} trough1 trough1 {}}
+test scale-8.2 {ScaleElement procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 100 -orient vertical -bd 1 -tick 20 -length 300
pack .s
.s set 30
update
list [.s identify 60 2] [.s identify 60 3] [.s identify 60 302] \
- [.s identify 60 303]
-} {{} trough1 trough2 {}}
-test scale-8.3 {ScaleElement procedure} {fonts} {
- catch {destroy .s}
+ [.s identify 60 303]
+} -cleanup {
+ deleteWindows
+} -result {{} trough1 trough2 {}}
+test scale-8.3 {ScaleElement procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 100 -orient vertical -bd 1 -tick 20 -length 300
pack .s
.s set 30
update
list [.s identify 60 83] [.s identify 60 84] [.s identify 60 113] \
- [.s identify 60 114] \
-} {trough1 slider slider trough2}
-test scale-8.4 {ScaleElement procedure} {
- catch {destroy .s}
+ [.s identify 60 114] \
+} -cleanup {
+ deleteWindows
+} -result {trough1 slider slider trough2}
+test scale-8.4 {ScaleElement procedure} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 100 -orient vertical -bd 4 -width 10 \
- -highlightthickness 1 -length 300 -showvalue 0
+ -highlightthickness 1 -length 300 -showvalue 0
pack .s
.s set 30
update
list [.s identify 4 40] [.s identify 5 40] [.s identify 22 40] \
- [.s identify 23 40] \
-} {{} trough1 trough1 {}}
-test scale-8.5 {ScaleElement procedure} {fonts} {
- catch {destroy .s}
+ [.s identify 23 40] \
+} -cleanup {
+ deleteWindows
+} -result {{} trough1 trough1 {}}
+test scale-8.5 {ScaleElement procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 100 -orient horizontal -bd 1 \
- -highlightthickness 2 -tick 20 -sliderlength 20 \
- -length 200 -label Test
+ -highlightthickness 2 -tick 20 -sliderlength 20 \
+ -length 200 -label Test
pack .s
.s set 30
update
list [.s identify 150 36] [.s identify 150 37] [.s identify 150 53] \
- [.s identify 150 54]
-} {{} trough2 trough2 {}}
-test scale-8.6 {ScaleElement procedure} {fonts} {
- catch {destroy .s}
+ [.s identify 150 54]
+} -cleanup {
+ deleteWindows
+} -result {{} trough2 trough2 {}}
+test scale-8.6 {ScaleElement procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 100 -orient horizontal -bd 2 \
- -highlightthickness 1 -tick 20 -length 200
+ -highlightthickness 1 -tick 20 -length 200
pack .s
.s set 30
update
list [.s identify 150 20] [.s identify 150 21] [.s identify 150 39] \
- [.s identify 150 40]
-} {{} trough2 trough2 {}}
-test scale-8.7 {ScaleElement procedure} {
- catch {destroy .s}
+ [.s identify 150 40]
+} -cleanup {
+ deleteWindows
+} -result {{} trough2 trough2 {}}
+test scale-8.7 {ScaleElement procedure} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 100 -orient horizontal -bd 4 -highlightthickness 2 \
- -length 200 -width 10 -showvalue 0
+ -length 200 -width 10 -showvalue 0
pack .s
.s set 30
update
list [.s identify 30 5] [.s identify 30 6] [.s identify 30 23] \
- [.s identify 30 24]
-} {{} trough1 trough1 {}}
-test scale-8.8 {ScaleElement procedure} {
- catch {destroy .s}
+ [.s identify 30 24]
+} -cleanup {
+ deleteWindows
+} -result {{} trough1 trough1 {}}
+test scale-8.8 {ScaleElement procedure} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 100 -orient horizontal -bd 1 -highlightthickness 2 \
- -tick 20 -sliderlength 20 -length 200 -label Test -showvalue 0
+ -tick 20 -sliderlength 20 -length 200 -label Test -showvalue 0
pack .s
.s set 30
update
list [.s identify 2 28] [.s identify 3 28] [.s identify 202 28] \
- [.s identify 203 28]
-} {{} trough1 trough2 {}}
-test scale-8.9 {ScaleElement procedure} {
- catch {destroy .s}
+ [.s identify 203 28]
+} -cleanup {
+ deleteWindows
+} -result {{} trough1 trough2 {}}
+test scale-8.9 {ScaleElement procedure} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 100 -orient horizontal -bd 1 -highlightthickness 2 \
- -tick 20 -sliderlength 20 -length 200 -label Test -showvalue 0
+ -tick 20 -sliderlength 20 -length 200 -label Test -showvalue 0
pack .s
.s set 80
update
list [.s identify 145 28] [.s identify 146 28] [.s identify 165 28] \
- [.s identify 166 28]
-} {trough1 slider slider trough2}
+ [.s identify 166 28]
+} -cleanup {
+ deleteWindows
+} -result {trough1 slider slider trough2}
-catch {destroy .s}
-scale .s -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
-pack .s
-update
-test scale-9.1 {PixelToValue procedure} {
+
+#widget used in 9.* tests
+destroy .s
+pack [scale .s]
+test scale-9.1 {PixelToValue procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
+ update
.s get 46 0
-} 0
-test scale-9.2 {PixelToValue procedure} {
+} -result 0
+test scale-9.2 {PixelToValue procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
+ update
.s get -10 9
-} 0
-test scale-9.3 {PixelToValue procedure} {
+} -result 0
+test scale-9.3 {PixelToValue procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
+ update
.s get -10 12
-} 1
-test scale-9.4 {PixelToValue procedure} {
+} -result 1
+test scale-9.4 {PixelToValue procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
+ update
.s get -10 46
-} 35
-test scale-9.5 {PixelToValue procedure} {
+} -result 35
+test scale-9.5 {PixelToValue procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
+ update
.s get -10 110
-} 99
-test scale-9.6 {PixelToValue procedure} {
+} -result 99
+test scale-9.6 {PixelToValue procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
+ update
.s get -10 111
-} 100
-test scale-9.7 {PixelToValue procedure} {
+} -result 100
+test scale-9.7 {PixelToValue procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
+ update
.s get -10 112
-} 100
-test scale-9.8 {PixelToValue procedure} {
+} -result 100
+test scale-9.8 {PixelToValue procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
+ update
.s get -10 154
-} 100
-.s configure -orient horizontal
-update
-test scale-9.9 {PixelToValue procedure} {
+} -result 100
+test scale-9.9 {PixelToValue procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal
+ update
.s get 76 152
-} 65
+} -result 65
+destroy .s
+
-test scale-10.1 {ValueToPixel procedure} {fonts} {
- catch {destroy .s}
+test scale-10.1 {ValueToPixel procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 0 -to 100 -sliderlength 20 -length 124 -bd 2 \
- -orient horizontal -label Test -tick 20
+ -orient horizontal -label Test -tick 20
pack .s
update
list [.s coords -10] [.s coords 40] [.s coords 1000]
-} {{16 47} {56 47} {116 47}}
-test scale-10.2 {ValueToPixel procedure} {fonts} {
- catch {destroy .s}
+} -cleanup {
+ deleteWindows
+} -result {{16 47} {56 47} {116 47}}
+test scale-10.2 {ValueToPixel procedure} -constraints {
+ fonts
+} -setup {
+ deleteWindows
+} -body {
scale .s -from 100 -to 0 -sliderlength 20 -length 122 -bd 1 \
- -orient vertical -label Test -tick 20
+ -orient vertical -label Test -tick 20
pack .s
update
list [.s coords -10] [.s coords 40] [.s coords 1000]
-} {{62 114} {62 74} {62 14}}
+} -cleanup {
+ deleteWindows
+} -result {{62 114} {62 74} {62 14}}
+
-test scale-11.1 {ScaleEventProc procedure} {
+test scale-11.1 {ScaleEventProc procedure} -setup {
+ deleteWindows
+} -body {
proc killScale value {
- global x
- if {$value > 30} {
- destroy .s1
- lappend x [winfo exists .s1] [info commands .s1]
- }
+ global x
+ if {$value > 30} {
+ destroy .s1
+ lappend x [winfo exists .s1] [info commands .s1]
+ }
}
- catch {destroy .s1}
set x initial
scale .s1 -from 0 -to 100 -command killScale
.s1 set 20
@@ -608,60 +1018,74 @@ test scale-11.1 {ScaleEventProc procedure} {
lappend x [winfo exists .s1]
.s1 set 40
update idletasks
+ return $x
+} -cleanup {
rename killScale {}
- set x
-} {initial 1 0 {}}
-test scale-11.2 {ScaleEventProc procedure} {
deleteWindows
+} -result {initial 1 0 {}}
+test scale-11.2 {ScaleEventProc procedure} -setup {
+ deleteWindows
+ set x {}
+} -body {
scale .s1 -bg #543210
rename .s1 .s2
- set x {}
lappend x [winfo children .]
lappend x [.s2 cget -bg]
destroy .s1
lappend x [info command .s*] [winfo children .]
-} {.s1 #543210 {} {}}
+} -cleanup {
+ deleteWindows
+} -result {.s1 #543210 {} {}}
-test scale-12.1 {ScaleCmdDeletedProc procedure} {
+test scale-12.1 {ScaleCmdDeletedProc procedure} -setup {
deleteWindows
+} -body {
scale .s1
rename .s1 {}
list [info command .s*] [winfo children .]
-} {{} {}}
+} -cleanup {
+ deleteWindows
+} -result {{} {}}
-catch {destroy .s}
-scale .s -from 0 -to 100 -command {set x} -variable y
-pack .s
+
+# Widget used in 13.* tests
+destroy .s
+pack [scale .s]
update
-proc varTrace args {
- global traceInfo
- set traceInfo $args
-}
-test scale-13.1 {SetScaleValue procedure} {
+test scale-13.1 {SetScaleValue procedure} -body {
+ .s configure -from 0 -to 100 -command {set x} -variable y
+ update
set x xyzzy
.s set 44
set result [list $x $y]
update
lappend result $x $y
-} {xyzzy 44 44 44}
-test scale-13.2 {SetScaleValue procedure} {
+} -result {xyzzy 44 44 44}
+test scale-13.2 {SetScaleValue procedure} -body {
.s set -3
.s get
-} 0
-test scale-13.3 {SetScaleValue procedure} {
+} -result 0
+test scale-13.3 {SetScaleValue procedure} -body {
.s set 105
.s get
-} 100
+} -result 100
.s configure -from 100 -to 0
-test scale-13.4 {SetScaleValue procedure} {
+test scale-13.4 {SetScaleValue procedure} -body {
.s set -3
.s get
-} 0
-test scale-13.5 {SetScaleValue procedure} {
+} -result 0
+test scale-13.5 {SetScaleValue procedure} -body {
.s set 105
.s get
-} 100
-test scale-13.6 {SetScaleValue procedure} {
+} -result 100
+test scale-13.6 {SetScaleValue procedure} -body {
+ proc varTrace args {
+ global traceInfo
+ set traceInfo $args
+ }
+ .s configure -from 0 -to 100 -command {set x} -variable y
+ update
+
.s set 50
update
trace variable y w varTrace
@@ -670,127 +1094,201 @@ test scale-13.6 {SetScaleValue procedure} {
.s set 50
update
list $x $traceInfo
-} {untouched empty}
+} -result {untouched empty}
-catch {destroy .s}
-scale .s -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 -orient horizontal
-pack .s
-update
-.s configure -resolution 4.0
+
+# Widget used in 14.* tests
+destroy .s
+pack [scale .s]
update
-test scale-14.1 {RoundToResolution procedure} {
+test scale-14.1 {RoundToResolution procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 4.0
+ update
.s get 84 152
-} 72
-test scale-14.2 {RoundToResolution procedure} {
+} -result 72
+test scale-14.2 {RoundToResolution procedure} -body {
+ .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 4.0
+ update
.s get 86 152
-} 76
-.s configure -from 100 -to 0
-update
-test scale-14.3 {RoundToResolution procedure} {
+} -result 76
+
+test scale-14.3 {RoundToResolution procedure} -body {
+ .s configure -from 100 -to 0 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 4.0
+ update
.s get 84 152
-} 28
-test scale-14.4 {RoundToResolution procedure} {
+} -result 28
+test scale-14.4 {RoundToResolution procedure} -body {
+ .s configure -from 100 -to 0 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 4.0
+ update
.s get 86 152
-} 24
-.s configure -from -100 -to 0
-update
-test scale-14.5 {RoundToResolution procedure} {
+} -result 24
+
+test scale-14.5 {RoundToResolution procedure} -body {
+ .s configure -from -100 -to 0 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 4.0
+ update
.s get 84 152
-} -28
-test scale-14.6 {RoundToResolution procedure} {
+} -result {-28}
+test scale-14.6 {RoundToResolution procedure} -body {
+ .s configure -from -100 -to 0 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 4.0
+ update
.s get 86 152
-} -24
-.s configure -from 0 -to -100
-update
-test scale-14.7 {RoundToResolution procedure} {
+} -result {-24}
+
+test scale-14.7 {RoundToResolution procedure} -body {
+ .s configure -from 0 -to -100 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 4.0
+ update
.s get 84 152
-} -72
-test scale-14.8 {RoundToResolution procedure} {
+} -result {-72}
+test scale-14.8 {RoundToResolution procedure} -body {
+ .s configure -from 0 -to -100 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 4.0
+ update
.s get 86 152
-} -76
-.s configure -from 0 -to 2.25 -resolution 0
-update
-test scale-14.9 {RoundToResolution procedure} {
+} -result {-76}
+
+test scale-14.9 {RoundToResolution procedure} -body {
+ .s configure -from 0 -to 2.25 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 0
+ update
.s get 84 152
-} 1.64
-test scale-14.10 {RoundToResolution procedure} {
+} -result {1.64}
+test scale-14.10 {RoundToResolution procedure} -body {
+ .s configure -from 0 -to 2.25 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 0
+ update
.s get 86 152
-} 1.69
-.s configure -from 0 -to 225 -resolution 0 -digits 5
-update
-test scale-14.11 {RoundToResolution procedure} {
+} -result {1.69}
+
+test scale-14.11 {RoundToResolution procedure} -body {
+ .s configure -from 0 -to 225 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 0 -digits 5
+ update
.s get 84 152
-} 164.25
-test scale-14.12 {RoundToResolution procedure} {
+} -result {164.25}
+test scale-14.12 {RoundToResolution procedure} -body {
+ .s configure -from 0 -to 225 -sliderlength 10 -length 114 -bd 2 \
+ -orient horizontal -resolution 0 -digits 5
+ update
.s get 86 152
-} 168.75
+} -result {168.75}
+destroy .s
-test scale-15.1 {ScaleVarProc procedure} {
- catch {destroy .s}
+
+test scale-15.1 {ScaleVarProc procedure} -setup {
+ deleteWindows
+} -body {
set y -130
scale .s -from 0 -to -200 -variable y -orient horizontal -length 150
pack .s
- set y
-} -130
-test scale-15.2 {ScaleVarProc procedure} {
- catch {destroy .s}
+ return $y
+} -result {-130}
+test scale-15.2 {ScaleVarProc procedure} -setup {
+ deleteWindows
+} -body {
set y -130
scale .s -from -200 -to 0 -variable y -orient horizontal -length 150
pack .s
set y -87
.s get
-} -87
-test scale-15.3 {ScaleVarProc procedure} {
- catch {destroy .s}
+} -result {-87}
+test scale-15.3 {ScaleVarProc procedure} -setup {
+ deleteWindows
+} -body {
set y -130
scale .s -from -200 -to 0 -variable y -orient horizontal -length 150
pack .s
- list [catch {set y 40q} msg] $msg [.s get]
-} {1 {can't set "y": can't assign non-numeric value to scale variable} -130}
-test scale-15.4 {ScaleVarProc procedure} {
- catch {destroy .s}
+ set y 40q
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {can't set "y": can't assign non-numeric value to scale variable}
+test scale-15.4 {ScaleVarProc procedure} -setup {
+ deleteWindows
+} -body {
+ set y -130
+ scale .s -from -200 -to 0 -variable y -orient horizontal -length 150
+ pack .s
+ catch {set y 40q}
+ .s get
+} -cleanup {
+ deleteWindows
+} -result {-130}
+test scale-15.5 {ScaleVarProc procedure} -setup {
+ deleteWindows
+} -body {
+ set y 1
+ scale .s -from 1 -to 0 -variable y -orient horizontal -length 150
+ pack .s
+ set y x
+} -cleanup {
+ deleteWindows
+} -returnCodes error -result {can't set "y": can't assign non-numeric value to scale variable}
+test scale-15.6 {ScaleVarProc procedure} -setup {
+ deleteWindows
+} -body {
set y 1
scale .s -from 1 -to 0 -variable y -orient horizontal -length 150
pack .s
- list [catch {set y x} msg] $msg [.s get]
-} {1 {can't set "y": can't assign non-numeric value to scale variable} 1}
-test scale-15.5 {ScaleVarProc procedure, variable deleted} {
- catch {destroy .s}
+ catch {set y x}
+ .s get
+} -cleanup {
+ deleteWindows
+} -result 1
+test scale-15.7 {ScaleVarProc procedure, variable deleted} -setup {
+ deleteWindows
+} -body {
set y 6
scale .s -from 10 -to 0 -variable y -orient horizontal -length 150 \
- -command "set x"
+ -command "set x"
pack .s
update
set x untouched
unset y
update
list [catch {set y} msg] $msg [.s get] $x
-} {0 6 6 untouched}
-test scale-15.6 {ScaleVarProc procedure, don't call -command} {
- catch {destroy .s}
+} -cleanup {
+ deleteWindows
+} -result {0 6 6 untouched}
+test scale-15.8 {ScaleVarProc procedure, don't call -command} -setup {
+ deleteWindows
+} -body {
set y 6
scale .s -from 0 -to 100 -variable y -orient horizontal -length 150 \
- -command "set x"
+ -command "set x"
pack .s
update
set x untouched
set y 60
update
list $x [.s get]
-} {untouched 60}
+} -cleanup {
+ deleteWindows
+} -result {untouched 60}
-set l [interp hidden]
-deleteWindows
-test scale-16.1 {scale widget vs hidden commands} {
- catch {destroy .s}
+test scale-16.1 {scale widget vs hidden commands} -body {
+ set l [interp hidden]
+ deleteWindows
scale .s
interp hide {} .s
destroy .s
- list [winfo children .] [interp hidden]
-} [list {} $l]
+ set res1 [list [winfo children .] [interp hidden]]
+ set res2 [list {} $l]
+ expr {$res1 eq $res2}
+} -cleanup {
+ deleteWindows
+} -result 1
+
-test scale-17.1 {bug fix 1786} {
+test scale-17.1 {bug fix 1786} -setup {
+ deleteWindows
+} -body {
# Perhaps x is set to {}, depending on what other tests have run.
# If x is unset, or set to something not convertable to a double,
# then the scale try to initialize its value with the contents
@@ -805,68 +1303,64 @@ test scale-17.1 {bug fix 1786} {
# Bug 4833 changed the result to realize that x should pick up
# a value from the scale. In an FPE occurs, it is due to the
# lack of errno being set to 0 by some libc's. (see bug 4942)
- set x
-} {100}
+ return $x
+} -cleanup {
+ deleteWindows
+} -result {100}
+
-test scale-18.1 {DestroyScale, -cursor option [Bug: 3897]} {
- catch {destroy .s}
+test scale-18.1 {DestroyScale, -cursor option [Bug: 3897]} -setup {
+ deleteWindows
+} -body {
scale .s -cursor trek
destroy .s
-} {}
-
-test scale-18.2 {Scale button 1 events [Bug 787065]} \
- -setup {
- catch {destroy .s}
- set y 5
- scale .s -from 0 -to 10 -variable y -orient horizontal -length 150
- pack .s
- tkwait visibility .s
- set ::error {}
- proc bgerror {args} {set ::error $args}
- } \
- -body {
- list [catch {
- event generate .s <1> -x 0 -y 0
- event generate .s <ButtonRelease-1> -x 0 -y 0
- update
- set ::error
- } msg] $msg
- } \
- -cleanup {
- unset ::error
- rename bgerror {}
- catch {destroy .s}
- } \
- -result {0 {}}
-
-test scale-18.3 {Scale button 2 events [Bug 787065]} \
- -setup {
- catch {destroy .s}
- set y 5
- scale .s -from 0 -to 10 -variable y -orient horizontal -length 150
- pack .s
- tkwait visibility .s
- set ::error {}
- proc bgerror {args} {set ::error $args}
- } \
- -body {
- list [catch {
- event generate .s <2> -x 0 -y 0
- event generate .s <ButtonRelease-2> -x 0 -y 0
- update
- set ::error
- } msg] $msg
- } \
- -cleanup {
- unset ::error
- rename bgerror {}
- catch {destroy .s}
- } \
- -result {0 {}}
-
-catch {destroy .s}
+} -result {}
+
+test scale-18.2 {Scale button 1 events [Bug 787065]} -setup {
+ destroy .s
+ set ::error {}
+ proc bgerror {args} {set ::error $args}
+} -body {
+ set y 5
+ scale .s -from 0 -to 10 -variable y -orient horizontal -length 150
+ pack .s
+ tkwait visibility .s
+ list [catch {
+ event generate .s <1> -x 0 -y 0
+ event generate .s <ButtonRelease-1> -x 0 -y 0
+ update
+ set ::error
+ } msg] $msg
+} -cleanup {
+ unset ::error
+ rename bgerror {}
+ destroy .s
+} -result {0 {}}
+
+test scale-18.3 {Scale button 2 events [Bug 787065]} -setup {
+ destroy .s
+ set ::error {}
+ proc bgerror {args} {set ::error $args}
+} -body {
+ set y 5
+ scale .s -from 0 -to 10 -variable y -orient horizontal -length 150
+ pack .s
+ tkwait visibility .s
+ list [catch {
+ event generate .s <2> -x 0 -y 0
+ event generate .s <ButtonRelease-2> -x 0 -y 0
+ update
+ set ::error
+ } msg] $msg
+} -cleanup {
+ unset ::error
+ rename bgerror {}
+ destroy .s
+} -result {0 {}}
+
+
option clear
# cleanup
cleanupTests
-return
+return \ No newline at end of file
diff --git a/tests/select.test b/tests/select.test
index 6c29e9f..9ae67ce 100644
--- a/tests/select.test
+++ b/tests/select.test
@@ -6,19 +6,19 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: select.test,v 1.17 2008/07/23 23:24:25 nijtmans Exp $
+# RCS: @(#) $Id: select.test,v 1.18 2008/08/28 08:52:05 aniap Exp $
#
# Note: Multiple display selection handling will only be tested if the
# environment variable TK_ALT_DISPLAY is set to an alternate display.
#
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
+namespace import ::tk::test:loadTkCommand
eval tcltest::configure $argv
tcltest::loadTestedCommands
-namespace import -force ::tk::test:loadTkCommand
-
global longValue selValue selInfo
set selValue {}
@@ -95,10 +95,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
}
@@ -112,36 +112,36 @@ foreach i {a b c d e f g j h i j k l m o p q r s t u v w x y z} {
# Now we start the main body of the test code
-test select-1.1 {Tk_CreateSelHandler procedure} {
+test select-1.1 {Tk_CreateSelHandler procedure} -body {
setup
lsort [selection get TARGETS]
-} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}
-test select-1.2 {Tk_CreateSelHandler procedure} {
+} -result {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}
+test select-1.2 {Tk_CreateSelHandler procedure} -body {
setup
selection handle .f1 {handler TEST} TEST
lsort [selection get TARGETS]
-} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}
-test select-1.3 {Tk_CreateSelHandler procedure} {
+} -result {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}
+test select-1.3 {Tk_CreateSelHandler procedure} -body {
global selValue selInfo
setup
selection handle .f1 {handler TEST} TEST
set selValue "Test value"
set selInfo ""
list [selection get TEST] $selInfo
-} {{Test value} {TEST 0 4000}}
-test select-1.4.1 {Tk_CreateSelHandler procedure} unix {
+} -result {{Test value} {TEST 0 4000}}
+test select-1.4.1 {Tk_CreateSelHandler procedure} -constraints unix -body {
setup
selection handle .f1 {handler TEST} TEST
selection handle .f1 {handler STRING}
lsort [selection get TARGETS]
-} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING}
-test select-1.4.2 {Tk_CreateSelHandler procedure} win {
+} -result {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING}
+test select-1.4.2 {Tk_CreateSelHandler procedure} -constraints win -body {
setup
selection handle .f1 {handler TEST} TEST
selection handle .f1 {handler STRING}
lsort [selection get TARGETS]
-} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}
-test select-1.5 {Tk_CreateSelHandler procedure} {
+} -result {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}
+test select-1.5 {Tk_CreateSelHandler procedure} -body {
global selValue selInfo
setup
selection handle .f1 {handler TEST} TEST
@@ -149,8 +149,8 @@ test select-1.5 {Tk_CreateSelHandler procedure} {
set selValue ""
set selInfo ""
list [selection get] $selInfo
-} {{} {STRING 0 4000}}
-test select-1.6.1 {Tk_CreateSelHandler procedure} unix {
+} -result {{} {STRING 0 4000}}
+test select-1.6.1 {Tk_CreateSelHandler procedure} -constraints unix -body {
global selValue selInfo
setup
selection handle .f1 {handler TEST} TEST
@@ -162,8 +162,8 @@ test select-1.6.1 {Tk_CreateSelHandler procedure} unix {
selection handle .f1 {handler TEST2} TEST
selection get -type TEST
list [set selInfo] [lsort [selection get TARGETS]]
-} {{STRING 0 4000 TEST 0 4000 TEST2 0 4000} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING}}
-test select-1.6.2 {Tk_CreateSelHandler procedure} win {
+} -result {{STRING 0 4000 TEST 0 4000 TEST2 0 4000} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING}}
+test select-1.6.2 {Tk_CreateSelHandler procedure} -constraints win -body {
global selValue selInfo
setup
selection handle .f1 {handler TEST} TEST
@@ -175,32 +175,32 @@ test select-1.6.2 {Tk_CreateSelHandler procedure} win {
selection handle .f1 {handler TEST2} TEST
selection get -type TEST
list [set selInfo] [lsort [selection get TARGETS]]
-} {{STRING 0 4000 TEST 0 4000 TEST2 0 4000} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}}
-test select-1.7.1 {Tk_CreateSelHandler procedure} unix {
+} -result {{STRING 0 4000 TEST 0 4000 TEST2 0 4000} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}}
+test select-1.7.1 {Tk_CreateSelHandler procedure} -constraints unix -body {
setup
selection own -selection CLIPBOARD .f1
selection handle -selection CLIPBOARD .f1 {handler TEST} TEST
selection handle -selection PRIMARY .f1 {handler TEST2} STRING
list [lsort [selection get -selection PRIMARY TARGETS]] \
[lsort [selection get -selection CLIPBOARD TARGETS]]
-} {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}}
-test select-1.7.2 {Tk_CreateSelHandler procedure} win {
+} -result {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}}
+test select-1.7.2 {Tk_CreateSelHandler procedure} -constraints win -body {
setup
selection own -selection CLIPBOARD .f1
selection handle -selection CLIPBOARD .f1 {handler TEST} TEST
selection handle -selection PRIMARY .f1 {handler TEST2} STRING
list [lsort [selection get -selection PRIMARY TARGETS]] \
[lsort [selection get -selection CLIPBOARD TARGETS]]
-} {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}}
-test select-1.8 {Tk_CreateSelHandler procedure} {
+} -result {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}}
+test select-1.8 {Tk_CreateSelHandler procedure} -body {
setup
selection handle -format INTEGER -type TEST .f1 {handler TEST}
lsort [selection get TARGETS]
-} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}
+} -result {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}
##############################################################################
-test select-2.1 {Tk_DeleteSelHandler procedure} unix {
+test select-2.1 {Tk_DeleteSelHandler procedure} -constraints unix -body {
setup
selection handle .f1 {handler STRING}
selection handle -type TEST .f1 {handler TEST}
@@ -208,8 +208,8 @@ test select-2.1 {Tk_DeleteSelHandler procedure} unix {
set result [list [lsort [selection get TARGETS]]]
selection handle -type TEST .f1 {}
lappend result [lsort [selection get TARGETS]]
-} {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER UTF8_STRING} {MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW USER UTF8_STRING}}
-test select-2.2 {Tk_DeleteSelHandler procedure} unix {
+} -result {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER UTF8_STRING} {MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW USER UTF8_STRING}}
+test select-2.2 {Tk_DeleteSelHandler procedure} -constraints unix -body {
setup
selection handle .f1 {handler STRING}
selection handle -type TEST .f1 {handler TEST}
@@ -217,8 +217,8 @@ test select-2.2 {Tk_DeleteSelHandler procedure} unix {
set result [list [lsort [selection get TARGETS]]]
selection handle -type USER .f1 {}
lappend result [lsort [selection get TARGETS]]
-} {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER UTF8_STRING} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING}}
-test select-2.3 {Tk_DeleteSelHandler procedure} unix {
+} -result {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER UTF8_STRING} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING}}
+test select-2.3 {Tk_DeleteSelHandler procedure} -constraints unix -body {
setup
selection own -selection CLIPBOARD .f1
selection handle -selection PRIMARY .f1 {handler STRING}
@@ -226,8 +226,8 @@ test select-2.3 {Tk_DeleteSelHandler procedure} unix {
selection handle -selection CLIPBOARD .f1 {}
list [lsort [selection get TARGETS]] \
[lsort [selection get -selection CLIPBOARD TARGETS]]
-} {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}}
-test select-2.4 {Tk_DeleteSelHandler procedure} win {
+} -result {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}}
+test select-2.4 {Tk_DeleteSelHandler procedure} -constraints win -body {
setup
selection handle .f1 {handler STRING}
selection handle -type TEST .f1 {handler TEST}
@@ -235,8 +235,8 @@ test select-2.4 {Tk_DeleteSelHandler procedure} win {
set result [list [lsort [selection get TARGETS]]]
selection handle -type TEST .f1 {}
lappend result [lsort [selection get TARGETS]]
-} {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER} {MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW USER}}
-test select-2.5 {Tk_DeleteSelHandler procedure} win {
+} -result {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER} {MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW USER}}
+test select-2.5 {Tk_DeleteSelHandler procedure} -constraints win -body {
setup
selection handle .f1 {handler STRING}
selection handle -type TEST .f1 {handler TEST}
@@ -244,8 +244,8 @@ test select-2.5 {Tk_DeleteSelHandler procedure} win {
set result [list [lsort [selection get TARGETS]]]
selection handle -type USER .f1 {}
lappend result [lsort [selection get TARGETS]]
-} {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}}
-test select-2.6 {Tk_DeleteSelHandler procedure} win {
+} -result {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}}
+test select-2.6 {Tk_DeleteSelHandler procedure} -constraints win -body {
setup
selection own -selection CLIPBOARD .f1
selection handle -selection PRIMARY .f1 {handler STRING}
@@ -253,40 +253,40 @@ test select-2.6 {Tk_DeleteSelHandler procedure} win {
selection handle -selection CLIPBOARD .f1 {}
list [lsort [selection get TARGETS]] \
[lsort [selection get -selection CLIPBOARD TARGETS]]
-} {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}}
-test select-2.7 {Tk_DeleteSelHandler procedure} {
+} -result {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}}
+test select-2.7 {Tk_DeleteSelHandler procedure} -body {
setup
selection handle .f1 {handler STRING}
list [selection handle .f1 {}] [selection handle .f1 {}]
-} {{} {}}
+} -result {{} {}}
##############################################################################
-test select-3.1 {Tk_OwnSelection procedure} {
+test select-3.1 {Tk_OwnSelection procedure} -body {
setup
selection own
-} {.f1}
-test select-3.2 {Tk_OwnSelection procedure} {
+} -result {.f1}
+test select-3.2 {Tk_OwnSelection procedure} -body {
setup .f1
set result [selection own]
setup .f2
lappend result [selection own]
-} {.f1 .f2}
-test select-3.3 {Tk_OwnSelection procedure} {
+} -result {.f1 .f2}
+test select-3.3 {Tk_OwnSelection procedure} -body {
setup .f1
setup .f2
selection own -selection CLIPBOARD .f1
list [selection own] [selection own -selection CLIPBOARD]
-} {.f2 .f1}
-test select-3.4 {Tk_OwnSelection procedure} {
+} -result {.f2 .f1}
+test select-3.4 {Tk_OwnSelection procedure} -body {
global lostSel
setup
set lostSel {owned}
selection own -command { set lostSel {lost} } .f1
selection clear .f1
set lostSel
-} {lost}
-test select-3.5 {Tk_OwnSelection procedure} {
+} -result {lost}
+test select-3.5 {Tk_OwnSelection procedure} -body {
global lostSel
setup .f1
setup .f2
@@ -294,8 +294,8 @@ test select-3.5 {Tk_OwnSelection procedure} {
selection own -command { set lostSel {lost1} } .f1
selection own -command { set lostSel {lost2} } .f2
list $lostSel [selection own]
-} {lost1 .f2}
-test select-3.6 {Tk_OwnSelection procedure} {
+} -result {lost1 .f2}
+test select-3.6 {Tk_OwnSelection procedure} -body {
global lostSel
setup
set lostSel {owned}
@@ -304,8 +304,8 @@ test select-3.6 {Tk_OwnSelection procedure} {
set result $lostSel
selection clear .f1
lappend result $lostSel
-} {owned lost2}
-test select-3.7 {Tk_OwnSelection procedure} unix {
+} -result {owned lost2}
+test select-3.7 {Tk_OwnSelection procedure} -constraints unix -body {
global lostSel
setup
setupbg
@@ -318,26 +318,30 @@ test select-3.7 {Tk_OwnSelection procedure} unix {
update
cleanupbg
lappend result $lostSel
-} {{} . lost1}
+} -result {{} . lost1}
# check reentrancy on selection replacement
-test select-3.8 {Tk_OwnSelection procedure} {
+test select-3.8 {Tk_OwnSelection procedure} -body {
setup
selection own -selection CLIPBOARD -command { destroy .f1 } .f1
selection own -selection CLIPBOARD .
-} {}
-test select-3.9 {Tk_OwnSelection procedure} {
+} -result {}
+test select-3.9 {Tk_OwnSelection procedure} -body {
setup .f2
setup .f1
selection own -selection CLIPBOARD -command { destroy .f2 } .f1
selection own -selection CLIPBOARD .f2
-} {}
+} -result {}
# multiple display tests
-test select-3.10 {Tk_OwnSelection procedure} {altDisplay} {
+test select-3.10 {Tk_OwnSelection procedure} -constraints {
+ altDisplay
+} -body {
setup .f1
setup .f2 $env(TK_ALT_DISPLAY)
list [selection own -displayof .f1] [selection own -displayof .f2]
-} {.f1 .f2}
-test select-3.11 {Tk_OwnSelection procedure} {altDisplay} {
+} -result {.f1 .f2}
+test select-3.11 {Tk_OwnSelection procedure} -constraints {
+ altDisplay
+} -body {
setup .f1
setup .f2 $env(TK_ALT_DISPLAY)
setupbg
@@ -348,27 +352,27 @@ test select-3.11 {Tk_OwnSelection procedure} {altDisplay} {
[selection own -displayof .f2]
cleanupbg
set result
-} {{} .f1 {}}
+} -result {{} .f1 {}}
##############################################################################
-test select-4.1 {Tk_ClearSelection procedure} {
+test select-4.1 {Tk_ClearSelection procedure} -body {
setup
set result [selection own]
selection clear .f1
lappend result [selection own]
-} {.f1 {}}
-test select-4.2 {Tk_ClearSelection procedure} {
+} -result {.f1 {}}
+test select-4.2 {Tk_ClearSelection procedure} -body {
setup
selection own -selection CLIPBOARD .f1
selection clear .f1
selection own -selection CLIPBOARD
-} {.f1}
-test select-4.3 {Tk_ClearSelection procedure} {
+} -result {.f1}
+test select-4.3 {Tk_ClearSelection procedure} -body {
setup
list [selection clear .f1] [selection clear .f1]
-} {{} {}}
-test select-4.4 {Tk_ClearSelection procedure} unix {
+} -result {{} {}}
+test select-4.4 {Tk_ClearSelection procedure} -constraints unix -body {
global lostSel
setup
setupbg
@@ -380,9 +384,11 @@ test select-4.4 {Tk_ClearSelection procedure} unix {
update
cleanupbg
lappend result [selection own]
-} {{} {}}
+} -result {{} {}}
# multiple display tests
-test select-4.5 {Tk_ClearSelection procedure} {altDisplay} {
+test select-4.5 {Tk_ClearSelection procedure} -constraints {
+ altDisplay
+} -body {
global lostSel lostSel2
setup .f1
setup .f2 $env(TK_ALT_DISPLAY)
@@ -394,8 +400,10 @@ test select-4.5 {Tk_ClearSelection procedure} {altDisplay} {
selection clear -displayof .f2
update
list $lostSel $lostSel2
-} {owned lost2}
-test select-4.6 {Tk_ClearSelection procedure} {unix altDisplay} {
+} -result {owned lost2}
+test select-4.6 {Tk_ClearSelection procedure} -constraints {
+ unix altDisplay
+} -body {
setup .f1
setup .f2 $env(TK_ALT_DISPLAY)
setupbg
@@ -410,71 +418,71 @@ test select-4.6 {Tk_ClearSelection procedure} {unix altDisplay} {
[selection own -displayof .f2] $lostSel $lostSel2
cleanupbg
set result
-} {{} .f1 {} owned lost2}
+} -result {{} .f1 {} owned lost2}
##############################################################################
-test select-5.1 {Tk_GetSelection procedure} {
+test select-5.1 {Tk_GetSelection procedure} -body {
setup
- list [catch {selection get TEST} msg] $msg
-} {1 {PRIMARY selection doesn't exist or form "TEST" not defined}}
-test select-5.2 {Tk_GetSelection procedure} {
+ selection get TEST
+} -returnCodes error -result {PRIMARY selection doesn't exist or form "TEST" not defined}
+test select-5.2 {Tk_GetSelection procedure} -body {
setup
selection get TK_WINDOW
-} {.f1}
-test select-5.3 {Tk_GetSelection procedure} {
+} -result {.f1}
+test select-5.3 {Tk_GetSelection procedure} -body {
setup
selection handle -selection PRIMARY .f1 {handler TEST} TEST
set selValue "Test value"
set selInfo ""
list [selection get TEST] $selInfo
-} {{Test value} {TEST 0 4000}}
-test select-5.4 {Tk_GetSelection procedure} {
+} -result {{Test value} {TEST 0 4000}}
+test select-5.4 {Tk_GetSelection procedure} -body {
setup
selection handle .f1 ERROR errHandler
- list [catch {selection get ERROR} msg] $msg
-} {1 {PRIMARY selection doesn't exist or form "ERROR" not defined}}
-test select-5.5 {Tk_GetSelection procedure} {
+ selection get ERROR
+} -returnCodes error -result {PRIMARY selection doesn't exist or form "ERROR" not defined}
+test select-5.5 {Tk_GetSelection procedure} -body {
setup
set selValue $longValue
set selInfo ""
selection handle .f1 {handler STRING}
list [selection get] $selInfo
-} "$longValue {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000}"
-test select-5.6 {Tk_GetSelection procedure} {
+} -result "$longValue {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000}"
+test select-5.6 {Tk_GetSelection procedure} -body {
proc weirdHandler {type offset count} {
selection handle .f1 {}
- handler $type $offset $count
+ handler $type $offset $count
}
setup
set selValue $longValue
set selInfo ""
selection handle .f1 {weirdHandler STRING}
- list [catch {selection get} msg] $msg
-} {1 {PRIMARY selection doesn't exist or form "STRING" not defined}}
-test select-5.7 {Tk_GetSelection procedure} {
+ selection get
+} -returnCodes error -result {PRIMARY selection doesn't exist or form "STRING" not defined}
+test select-5.7 {Tk_GetSelection procedure} -body {
proc weirdHandler {type offset count} {
destroy .f1
- handler $type $offset $count
+ handler $type $offset $count
}
setup
set selValue "Test Value"
set selInfo ""
selection handle .f1 {weirdHandler STRING}
- list [catch {selection get} msg] $msg
-} {1 {PRIMARY selection doesn't exist or form "STRING" not defined}}
-test select-5.8 {Tk_GetSelection procedure} {
+ selection get
+} -returnCodes error -result {PRIMARY selection doesn't exist or form "STRING" not defined}
+test select-5.8 {Tk_GetSelection procedure} -body {
proc weirdHandler {type offset count} {
selection clear
- handler $type $offset $count
+ handler $type $offset $count
}
setup
set selValue $longValue
set selInfo ""
selection handle .f1 {weirdHandler STRING}
list [selection get] $selInfo [catch {selection get} msg] $msg
-} "$longValue {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000} 1 {PRIMARY selection doesn't exist or form \"STRING\" not defined}"
-test select-5.9 {Tk_GetSelection procedure} unix {
+} -result "$longValue {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000} 1 {PRIMARY selection doesn't exist or form \"STRING\" not defined}"
+test select-5.9 {Tk_GetSelection procedure} -constraints unix -body {
setup
setupbg
selection handle -selection PRIMARY .f1 {handler TEST} TEST
@@ -485,8 +493,8 @@ test select-5.9 {Tk_GetSelection procedure} unix {
lappend result [dobg {selection get TEST}]
cleanupbg
lappend result $selInfo
-} {{Test value} {TEST 0 4000}}
-test select-5.10 {Tk_GetSelection procedure} unix {
+} -result {{Test value} {TEST 0 4000}}
+test select-5.10 {Tk_GetSelection procedure} -constraints unix -body {
setup
setupbg
selection handle -selection PRIMARY .f1 {handler TEST} TEST
@@ -498,9 +506,11 @@ test select-5.10 {Tk_GetSelection procedure} unix {
lappend result [dobg {selection get TEST} 1]
cleanupbg
lappend result $selInfo
-} {{selection owner didn't respond} {}}
+} -result {{selection owner didn't respond} {}}
# multiple display tests
-test select-5.11 {Tk_GetSelection procedure} {altDisplay} {
+test select-5.11 {Tk_GetSelection procedure} -constraints {
+ altDisplay
+} -body {
setup .f1
setup .f2 $env(TK_ALT_DISPLAY)
selection handle -selection PRIMARY .f1 {handler TEST} TEST
@@ -511,8 +521,10 @@ test select-5.11 {Tk_GetSelection procedure} {altDisplay} {
set selValue "Test value2"
set selInfo ""
lappend result [selection get -displayof .f2 TEST] $selInfo
-} {{Test value} {TEST 0 4000} {Test value2} {TEST2 0 4000}}
-test select-5.12 {Tk_GetSelection procedure} {altDisplay} {
+} -result {{Test value} {TEST 0 4000} {Test value2} {TEST2 0 4000}}
+test select-5.12 {Tk_GetSelection procedure} -constraints {
+ altDisplay
+} -body {
global lostSel lostSel2
setup .f1
setup .f2 $env(TK_ALT_DISPLAY)
@@ -525,8 +537,10 @@ test select-5.12 {Tk_GetSelection procedure} {altDisplay} {
set selInfo ""
lappend result [catch {selection get -displayof .f2 TEST} msg] $msg \
$selInfo
-} {0 {Test value} {TEST 0 4000} 1 {PRIMARY selection doesn't exist or form "TEST" not defined} {}}
-test select-5.13 {Tk_GetSelection procedure} {unix altDisplay} {
+} -result {0 {Test value} {TEST 0 4000} 1 {PRIMARY selection doesn't exist or form "TEST" not defined} {}}
+test select-5.13 {Tk_GetSelection procedure} -constraints {
+ unix altDisplay
+} -body {
setup .f1
setup .f2 $env(TK_ALT_DISPLAY)
setupbg
@@ -543,8 +557,10 @@ test select-5.13 {Tk_GetSelection procedure} {unix altDisplay} {
lappend result [dobg "selection get TEST"]
cleanupbg
lappend result $selInfo
-} {{Test value} {Test value2} {TEST2 0 4000 TEST 0 4000}}
-test select-5.14 {Tk_GetSelection procedure} {unix altDisplay} {
+} -result {{Test value} {Test value2} {TEST2 0 4000 TEST 0 4000}}
+test select-5.14 {Tk_GetSelection procedure} -constraints {
+ unix altDisplay
+} -body {
setup .f1
setup .f2 $env(TK_ALT_DISPLAY)
setupbg
@@ -561,81 +577,81 @@ test select-5.14 {Tk_GetSelection procedure} {unix altDisplay} {
lappend result [dobg "selection get TEST"]
cleanupbg
lappend result $selInfo
-} {{PRIMARY selection doesn't exist or form "TEST" not defined} {Test value2} {TEST 0 4000}}
+} -result {{PRIMARY selection doesn't exist or form "TEST" not defined} {Test value2} {TEST 0 4000}}
##############################################################################
-test select-6.1 {Tk_SelectionCmd procedure} {
- list [catch {selection} cmd] $cmd
-} {1 {wrong # args: should be "selection option ?arg ...?"}}
+test select-6.1 {Tk_SelectionCmd procedure} -body {
+ selection
+} -returnCodes error -result {wrong # args: should be "selection option ?arg ...?"}
# selection clear
-test select-6.2 {Tk_SelectionCmd procedure} {
- list [catch {selection clear -selection} cmd] $cmd
-} {1 {value for "-selection" missing}}
-test select-6.3 {Tk_SelectionCmd procedure} {
+test select-6.2 {Tk_SelectionCmd procedure} -body {
+ selection clear -selection
+} -returnCodes error -result {value for "-selection" missing}
+test select-6.3 {Tk_SelectionCmd procedure} -body {
setup
selection own .
set result [selection own]
selection clear -displayof .f1
lappend result [selection own]
-} {. {}}
-test select-6.4 {Tk_SelectionCmd procedure} {
+} -result {. {}}
+test select-6.4 {Tk_SelectionCmd procedure} -body {
setup
selection own -selection CLIPBOARD .f1
set result [list [selection own] [selection own -selection CLIPBOARD]]
selection clear -selection CLIPBOARD .f1
lappend result [selection own] [selection own -selection CLIPBOARD]
-} {.f1 .f1 .f1 {}}
-test select-6.5 {Tk_SelectionCmd procedure} {
+} -result {.f1 .f1 .f1 {}}
+test select-6.5 {Tk_SelectionCmd procedure} -body {
setup
selection own -selection CLIPBOARD .
set result [list [selection own] [selection own -selection CLIPBOARD]]
selection clear -selection CLIPBOARD -displayof .f1
lappend result [selection own] [selection own -selection CLIPBOARD]
-} {.f1 . .f1 {}}
-test select-6.6 {Tk_SelectionCmd procedure} {
- list [catch {selection clear -badopt foo} cmd] $cmd
-} {1 {bad option "-badopt": must be -displayof or -selection}}
-test select-6.7 {Tk_SelectionCmd procedure} {
- list [catch {selection clear -selectionfoo foo} cmd] $cmd
-} {1 {bad option "-selectionfoo": must be -displayof or -selection}}
-test select-6.8 {Tk_SelectionCmd procedure} {
- catch {destroy .f2}
- list [catch {selection clear -displayof .f2} cmd] $cmd
-} {1 {bad window path name ".f2"}}
-test select-6.9 {Tk_SelectionCmd procedure} {
- catch {destroy .f2}
- list [catch {selection clear .f2} cmd] $cmd
-} {1 {bad window path name ".f2"}}
-test select-6.10 {Tk_SelectionCmd procedure} {
+} -result {.f1 . .f1 {}}
+test select-6.6 {Tk_SelectionCmd procedure} -body {
+ selection clear -badopt foo
+} -returnCodes error -result {bad option "-badopt": must be -displayof or -selection}
+test select-6.7 {Tk_SelectionCmd procedure} -body {
+ selection clear -selectionfoo foo
+} -returnCodes error -result {bad option "-selectionfoo": must be -displayof or -selection}
+test select-6.8 {Tk_SelectionCmd procedure} -body {
+ destroy .f2
+ selection clear -displayof .f2
+} -returnCodes error -result {bad window path name ".f2"}
+test select-6.9 {Tk_SelectionCmd procedure} -body {
+ destroy .f2
+ selection clear .f2
+} -returnCodes error -result {bad window path name ".f2"}
+test select-6.10 {Tk_SelectionCmd procedure} -body {
setup
set result [selection own -selection PRIMARY]
selection clear
lappend result [selection own -selection PRIMARY]
-} {.f1 {}}
-test select-6.11 {Tk_SelectionCmd procedure} {
+} -result {.f1 {}}
+test select-6.11 {Tk_SelectionCmd procedure} -body {
setup
selection own -selection CLIPBOARD .f1
set result [selection own -selection CLIPBOARD]
selection clear -selection CLIPBOARD
lappend result [selection own -selection CLIPBOARD]
-} {.f1 {}}
-test select-6.12 {Tk_SelectionCmd procedure} {
- list [catch {selection clear foo bar} cmd] $cmd
-} {1 {wrong # args: should be "selection clear ?-option value ...?"}}
+} -result {.f1 {}}
+test select-6.12 {Tk_SelectionCmd procedure} -body {
+ selection clear foo bar
+} -returnCodes error -result {wrong # args: should be "selection clear ?-option value ...?"}
# selection get
-test select-6.13 {Tk_SelectionCmd procedure} {
- list [catch {selection get -selection} cmd] $cmd
-} {1 {value for "-selection" missing}}
-test select-6.14 {Tk_SelectionCmd procedure} {
+test select-6.13 {Tk_SelectionCmd procedure} -body {
+ selection get -selection
+} -returnCodes error -result {value for "-selection" missing}
+test select-6.14 {Tk_SelectionCmd procedure} -body {
global selValue selInfo
setup
selection handle .f1 {handler TEST}
set selValue "Test value"
set selInfo ""
list [selection get -displayof .f1] $selInfo
-} {{Test value} {TEST 0 4000}}
-test select-6.15 {Tk_SelectionCmd procedure} {
+} -result {{Test value} {TEST 0 4000}}
+test select-6.15 {Tk_SelectionCmd procedure} -body {
global selValue selInfo
setup
selection handle .f1 {handler STRING}
@@ -644,8 +660,8 @@ test select-6.15 {Tk_SelectionCmd procedure} {
set selValue "Test value"
set selInfo ""
list [selection get -selection CLIPBOARD] $selInfo
-} {{Test value} {TEST 0 4000}}
-test select-6.16 {Tk_SelectionCmd procedure} {
+} -result {{Test value} {TEST 0 4000}}
+test select-6.16 {Tk_SelectionCmd procedure} -body {
global selValue selInfo
setup
selection handle -type TEST .f1 {handler TEST}
@@ -653,21 +669,21 @@ test select-6.16 {Tk_SelectionCmd procedure} {
set selValue "Test value"
set selInfo ""
list [selection get -type TEST] $selInfo
-} {{Test value} {TEST 0 4000}}
-test select-6.17 {Tk_SelectionCmd procedure} {
- list [catch {selection get -badopt foo} cmd] $cmd
-} {1 {bad option "-badopt": must be -displayof, -selection, or -type}}
-test select-6.18 {Tk_SelectionCmd procedure} {
- list [catch {selection get -selectionfoo foo} cmd] $cmd
-} {1 {bad option "-selectionfoo": must be -displayof, -selection, or -type}}
-test select-6.19 {Tk_SelectionCmd procedure} {
+} -result {{Test value} {TEST 0 4000}}
+test select-6.17 {Tk_SelectionCmd procedure} -body {
+ selection get -badopt foo
+} -returnCodes error -result {bad option "-badopt": must be -displayof, -selection, or -type}
+test select-6.18 {Tk_SelectionCmd procedure} -body {
+ selection get -selectionfoo foo
+} -returnCodes error -result {bad option "-selectionfoo": must be -displayof, -selection, or -type}
+test select-6.19 {Tk_SelectionCmd procedure} -body {
catch { destroy .f2 }
- list [catch {selection get -displayof .f2} cmd] $cmd
-} {1 {bad window path name ".f2"}}
-test select-6.20 {Tk_SelectionCmd procedure} {
- list [catch {selection get foo bar} cmd] $cmd
-} {1 {wrong # args: should be "selection get ?-option value ...?"}}
-test select-6.21 {Tk_SelectionCmd procedure} {
+ selection get -displayof .f2
+} -returnCodes error -result {bad window path name ".f2"}
+test select-6.20 {Tk_SelectionCmd procedure} -body {
+ selection get foo bar
+} -returnCodes error -result {wrong # args: should be "selection get ?-option value ...?"}
+test select-6.21 {Tk_SelectionCmd procedure} -body {
global selValue selInfo
setup
selection handle -type TEST .f1 {handler TEST}
@@ -675,54 +691,54 @@ test select-6.21 {Tk_SelectionCmd procedure} {
set selValue "Test value"
set selInfo ""
list [selection get TEST] $selInfo
-} {{Test value} {TEST 0 4000}}
+} -result {{Test value} {TEST 0 4000}}
# selection handle
# most of the handle section has been covered earlier
-test select-6.22 {Tk_SelectionCmd procedure} {
- list [catch {selection handle -selection} cmd] $cmd
-} {1 {value for "-selection" missing}}
-test select-6.23 {Tk_SelectionCmd procedure} {
+test select-6.22 {Tk_SelectionCmd procedure} -body {
+ selection handle -selection
+} -returnCodes error -result {value for "-selection" missing}
+test select-6.23 {Tk_SelectionCmd procedure} -body {
global selValue selInfo
setup
set selValue "Test value"
set selInfo ""
list [selection handle -format INTEGER .f1 {handler TEST}] [selection get -displayof .f1] $selInfo
-} {{} {Test value} {TEST 0 4000}}
-test select-6.24 {Tk_SelectionCmd procedure} {
- list [catch {selection handle -badopt foo} cmd] $cmd
-} {1 {bad option "-badopt": must be -format, -selection, or -type}}
-test select-6.25 {Tk_SelectionCmd procedure} {
- list [catch {selection handle -selectionfoo foo} cmd] $cmd
-} {1 {bad option "-selectionfoo": must be -format, -selection, or -type}}
-test select-6.26 {Tk_SelectionCmd procedure} {
- list [catch {selection handle} cmd] $cmd
-} {1 {wrong # args: should be "selection handle ?-option value ...? window command"}}
-test select-6.27 {Tk_SelectionCmd procedure} {
- list [catch {selection handle .} cmd] $cmd
-} {1 {wrong # args: should be "selection handle ?-option value ...? window command"}}
-test select-6.28 {Tk_SelectionCmd procedure} {
- list [catch {selection handle . foo bar baz blat} cmd] $cmd
-} {1 {wrong # args: should be "selection handle ?-option value ...? window command"}}
-test select-6.29 {Tk_SelectionCmd procedure} {
+} -result {{} {Test value} {TEST 0 4000}}
+test select-6.24 {Tk_SelectionCmd procedure} -body {
+ selection handle -badopt foo
+} -returnCodes error -result {bad option "-badopt": must be -format, -selection, or -type}
+test select-6.25 {Tk_SelectionCmd procedure} -body {
+ selection handle -selectionfoo foo
+} -returnCodes error -result {bad option "-selectionfoo": must be -format, -selection, or -type}
+test select-6.26 {Tk_SelectionCmd procedure} -body {
+ selection handle
+} -returnCodes error -result {wrong # args: should be "selection handle ?-option value ...? window command"}
+test select-6.27 {Tk_SelectionCmd procedure} -body {
+ selection handle .
+} -returnCodes error -result {wrong # args: should be "selection handle ?-option value ...? window command"}
+test select-6.28 {Tk_SelectionCmd procedure} -body {
+ selection handle . foo bar baz blat
+} -returnCodes error -result {wrong # args: should be "selection handle ?-option value ...? window command"}
+test select-6.29 {Tk_SelectionCmd procedure} -body {
catch { destroy .f2 }
- list [catch {selection handle .f2 dummy} cmd] $cmd
-} {1 {bad window path name ".f2"}}
+ selection handle .f2 dummy
+} -returnCodes error -result {bad window path name ".f2"}
# selection own
-test select-6.30 {Tk_SelectionCmd procedure} {
- list [catch {selection own -selection} cmd] $cmd
-} {1 {value for "-selection" missing}}
-test select-6.31 {Tk_SelectionCmd procedure} {
+test select-6.30 {Tk_SelectionCmd procedure} -body {
+ selection own -selection
+} -returnCodes error -result {value for "-selection" missing}
+test select-6.31 {Tk_SelectionCmd procedure} -body {
setup
selection own .
selection own -displayof .f1
-} {.}
-test select-6.32 {Tk_SelectionCmd procedure} {
+} -result {.}
+test select-6.32 {Tk_SelectionCmd procedure} -body {
setup
selection own .
selection own -selection CLIPBOARD .f1
list [selection own] [selection own -selection CLIPBOARD]
-} {. .f1}
-test select-6.33 {Tk_SelectionCmd procedure} {
+} -result {. .f1}
+test select-6.33 {Tk_SelectionCmd procedure} -body {
global lostSel
setup
set lostSel owned
@@ -731,40 +747,40 @@ test select-6.33 {Tk_SelectionCmd procedure} {
set result $lostSel
selection own .f1
lappend result $lostSel
-} {owned lost}
-test select-6.34 {Tk_SelectionCmd procedure} {
- list [catch {selection own -badopt foo} cmd] $cmd
-} {1 {bad option "-badopt": must be -command, -displayof, or -selection}}
-test select-6.35 {Tk_SelectionCmd procedure} {
- list [catch {selection own -selectionfoo foo} cmd] $cmd
-} {1 {bad option "-selectionfoo": must be -command, -displayof, or -selection}}
-test select-6.36 {Tk_SelectionCmd procedure} {
- catch {destroy .f2}
- list [catch {selection own -displayof .f2} cmd] $cmd
-} {1 {bad window path name ".f2"}}
-test select-6.37 {Tk_SelectionCmd procedure} {
- catch {destroy .f2}
- list [catch {selection own .f2} cmd] $cmd
-} {1 {bad window path name ".f2"}}
-test select-6.38 {Tk_SelectionCmd procedure} {
- list [catch {selection own foo bar baz} cmd] $cmd
-} {1 {wrong # args: should be "selection own ?-option value ...? ?window?"}}
-test select-6.39 {Tk_SelectionCmd procedure} {
- list [catch {selection foo} cmd] $cmd
-} {1 {bad option "foo": must be clear, get, handle, or own}}
+} -result {owned lost}
+test select-6.34 {Tk_SelectionCmd procedure} -body {
+ selection own -badopt foo
+} -returnCodes error -result {bad option "-badopt": must be -command, -displayof, or -selection}
+test select-6.35 {Tk_SelectionCmd procedure} -body {
+ selection own -selectionfoo foo
+} -returnCodes error -result {bad option "-selectionfoo": must be -command, -displayof, or -selection}
+test select-6.36 {Tk_SelectionCmd procedure} -body {
+ destroy .f2
+ selection own -displayof .f2
+} -returnCodes error -result {bad window path name ".f2"}
+test select-6.37 {Tk_SelectionCmd procedure} -body {
+ destroy .f2
+ selection own .f2
+} -returnCodes error -result {bad window path name ".f2"}
+test select-6.38 {Tk_SelectionCmd procedure} -body {
+ selection own foo bar baz
+} -returnCodes error -result {wrong # args: should be "selection own ?-option value ...? ?window?"}
+test select-6.39 {Tk_SelectionCmd procedure} -body {
+ selection foo
+} -returnCodes error -result {bad option "foo": must be clear, get, handle, or own}
##############################################################################
# This test is non-portable because some old X11/News servers ignore
# a selection request when the window doesn't exist, which causes a
# different error message.
-test select-7.1 {TkSelDeadWindow procedure} nonPortable {
+test select-7.1 {TkSelDeadWindow procedure} -constraints nonPortable -body {
setup
selection handle .f1 { handler TEST }
set result [selection own]
destroy .f1
lappend result [selection own] [catch {selection get} msg] $msg
-} {.f1 {} 1 {PRIMARY selection doesn't exist or form "STRING" not defined}}
+} -result {.f1 {} 1 {PRIMARY selection doesn't exist or form "STRING" not defined}}
##############################################################################
@@ -790,14 +806,14 @@ test select-9.1 {SelCvtToX and SelCvtFromX procedures} -setup {
set selValue "1024"
set selInfo ""
selection handle -selection PRIMARY -format INTEGER -type TEST \
- .f1 {handler TEST}
+ .f1 {handler TEST}
update
set result ""
lappend result [dobg {selection get TEST}]
cleanupbg
lappend result $selInfo
} -result {0x400 {TEST 0 4000}}
-test select-9.2 {SelCvtToX and SelCvtFromX procedures} unix {
+test select-9.2 {SelCvtToX and SelCvtFromX procedures} -constraints unix -body {
setup
setupbg
set selValue "1024 0xffff 2048 -2 "
@@ -808,8 +824,8 @@ test select-9.2 {SelCvtToX and SelCvtFromX procedures} unix {
lappend result [dobg {selection get TEST}]
cleanupbg
lappend result $selInfo
-} {{0x400 0xffff 0x800 0xfffffffe} {TEST 0 4000}}
-test select-9.3 {SelCvtToX and SelCvtFromX procedures} unix {
+} -result {{0x400 0xffff 0x800 0xfffffffe} {TEST 0 4000}}
+test select-9.3 {SelCvtToX and SelCvtFromX procedures} -constraints unix -body {
setup
setupbg
set selValue " "
@@ -820,8 +836,8 @@ test select-9.3 {SelCvtToX and SelCvtFromX procedures} unix {
lappend result [dobg {selection get TEST}]
cleanupbg
lappend result $selInfo
-} {{} {TEST 0 4000}}
-test select-9.4 {SelCvtToX and SelCvtFromX procedures} unix {
+} -result {{} {TEST 0 4000}}
+test select-9.4 {SelCvtToX and SelCvtFromX procedures} -constraints unix -body {
setup
setupbg
set selValue "16 foobar 32"
@@ -832,7 +848,7 @@ test select-9.4 {SelCvtToX and SelCvtFromX procedures} unix {
lappend result [dobg {selection get TEST}]
cleanupbg
lappend result $selInfo
-} {{0x10 0x0 0x20} {TEST 0 4000}}
+} -result {{0x10 0x0 0x20} {TEST 0 4000}}
test select-9.5 {SelCvtToX and SelCvtFromX procedures} -setup {
setup
setupbg
@@ -843,7 +859,7 @@ test select-9.5 {SelCvtToX and SelCvtFromX procedures} -setup {
set selInfo ""
set selType {text/x-tk-test;detail="foo bar"}
selection handle -selection PRIMARY -format STRING -type $selType \
- .f1 [list handler $selType]
+ .f1 [list handler $selType]
lsort [dobg {selection get TARGETS}]
} -cleanup {
cleanupbg
@@ -854,11 +870,13 @@ test select-9.5 {SelCvtToX and SelCvtFromX procedures} -setup {
# note, we are not testing MULTIPLE style selections
# most control paths have been exercised above
-test select-10.1 {ConvertSelection procedure, race with selection clear} unix {
+test select-10.1 {ConvertSelection procedure, race with selection clear} -constraints {
+ unix
+} -body {
setup
proc Ready {fd} {
- variable x
- lappend x [gets $fd]
+ variable x
+ lappend x [gets $fd]
}
set fd [open "|[list [interpreter] -geometry +0+0 -name tktest]" r+]
puts $fd "puts foo; [loadTkCommand]; flush stdout"
@@ -881,10 +899,11 @@ test select-10.1 {ConvertSelection procedure, race with selection clear} unix {
# a "broken pipe" error when Tk was actually [load]ed in the child.
catch {close $fd}
lappend x $selInfo
-} {{1 PRIMARY selection doesn't exist or form "STRING" not defined} {}}
-test select-10.2 {ConvertSelection procedure} unix {
+} -result {{1 PRIMARY selection doesn't exist or form "STRING" not defined} {}}
+test select-10.2 {ConvertSelection procedure} -constraints unix -setup {
setup
setupbg
+} -body {
set selValue [string range $longValue 0 3999]
set selInfo ""
selection handle .f1 {handler STRING}
@@ -892,21 +911,24 @@ test select-10.2 {ConvertSelection procedure} unix {
lappend result [dobg {selection get}]
cleanupbg
lappend result $selInfo
-} [list [string range $longValue 0 3999] {STRING 0 4000 STRING 4000 4000 STRING 0 4000 STRING 4000 4000}]
-test select-10.3 {ConvertSelection procedure} unix {
+} -result [list [string range $longValue 0 3999] {STRING 0 4000 STRING 4000 4000 STRING 0 4000 STRING 4000 4000}]
+test select-10.3 {ConvertSelection procedure} -constraints unix -setup {
setup
setupbg
+} -body {
selection handle .f1 ERROR errHandler
- set result ""
- lappend result [dobg {selection get ERROR}]
+ dobg {selection get ERROR}
+} -cleanup {
cleanupbg
- set result
-} {{PRIMARY selection doesn't exist or form "ERROR" not defined}}
+} -result {PRIMARY selection doesn't exist or form "ERROR" not defined}
# testing timers
# This one hangs in Exceed
-test select-10.4 {ConvertSelection procedure} {unix noExceed} {
+test select-10.4 {ConvertSelection procedure} -constraints {
+ unix noExceed
+} -setup {
setup
setupbg
+} -body {
set selValue $longValue
set selInfo ""
selection handle .f1 {errIncrHandler STRING}
@@ -915,10 +937,13 @@ test select-10.4 {ConvertSelection procedure} {unix noExceed} {
lappend result [dobg {selection get}]
cleanupbg
lappend result $selInfo
-} {{selection owner didn't respond} {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000 STRING 0 4000 STRING 4000 4000}}
-test select-10.5 {ConvertSelection procedure, reentrancy issues} unix {
+} -result {{selection owner didn't respond} {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000 STRING 0 4000 STRING 4000 4000}}
+test select-10.5 {ConvertSelection procedure, reentrancy issues} -constraints {
+ unix
+} -setup {
setup
setupbg
+} -body {
set selValue "Test value"
set selInfo ""
selection handle -type TEST .f1 { handler TEST }
@@ -927,14 +952,17 @@ test select-10.5 {ConvertSelection procedure, reentrancy issues} unix {
lappend result [dobg {selection get}]
cleanupbg
lappend result $selInfo
-} {{PRIMARY selection doesn't exist or form "STRING" not defined} {.f1 STRING 0 4000}}
-test select-10.6 {ConvertSelection procedure, reentrancy issues} unix {
- proc weirdHandler {type offset count} {
- destroy .f1
- handler $type $offset $count
- }
+} -result {{PRIMARY selection doesn't exist or form "STRING" not defined} {.f1 STRING 0 4000}}
+test select-10.6 {ConvertSelection procedure, reentrancy issues} -constraints {
+ unix
+} -setup {
setup
setupbg
+} -body {
+ proc weirdHandler {type offset count} {
+ destroy .f1
+ handler $type $offset $count
+ }
set selValue $longValue
set selInfo ""
selection handle .f1 {weirdHandler STRING}
@@ -942,14 +970,15 @@ test select-10.6 {ConvertSelection procedure, reentrancy issues} unix {
lappend result [dobg {selection get}]
cleanupbg
lappend result $selInfo
-} {{PRIMARY selection doesn't exist or form "STRING" not defined} {STRING 0 4000}}
+} -result {{PRIMARY selection doesn't exist or form "STRING" not defined} {STRING 0 4000}}
##############################################################################
# testing reentrancy
-test select-11.1 {TkSelPropProc procedure} unix {
+test select-11.1 {TkSelPropProc procedure} -constraints unix -setup {
setup
setupbg
+} -body {
set selValue $longValue
set selInfo ""
selection handle -type TEST .f1 { handler TEST }
@@ -959,28 +988,28 @@ test select-11.1 {TkSelPropProc procedure} unix {
lappend result [dobg {selection get}]
cleanupbg
lappend result $selInfo
-} {{selection owner didn't respond} {.f1 STRING 0 4000 .f1 STRING 4000 4000 .f1 STRING 8000 4000 .f1 STRING 12000 4000 .f1 STRING 16000 4000 .f1 STRING 0 4000 .f1 STRING 4000 4000}}
+} -result {{selection owner didn't respond} {.f1 STRING 0 4000 .f1 STRING 4000 4000 .f1 STRING 8000 4000 .f1 STRING 12000 4000 .f1 STRING 16000 4000 .f1 STRING 0 4000 .f1 STRING 4000 4000}}
##############################################################################
# Note, this assumes we are using CurrentTtime
-test select-12.1 {DefaultSelection procedure} unix {
+test select-12.1 {DefaultSelection procedure} -constraints unix -body {
setup
set result [selection get -type TIMESTAMP]
setupbg
lappend result [dobg {selection get -type TIMESTAMP}]
cleanupbg
set result
-} {0x0 0x0}
-test select-12.2 {DefaultSelection procedure} unix {
+} -result {0x0 0x0}
+test select-12.2 {DefaultSelection procedure} -constraints unix -body {
setup
set result [lsort [list [selection get -type TARGETS]]]
setupbg
lappend result [dobg {lsort [selection get -type TARGETS]}]
cleanupbg
set result
-} {{MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}}
-test select-12.3 {DefaultSelection procedure} unix {
+} -result {{MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}}
+test select-12.3 {DefaultSelection procedure} -constraints unix -body {
setup
selection handle .f1 {handler TEST} TEST
set result [list [lsort [selection get -type TARGETS]]]
@@ -988,25 +1017,26 @@ test select-12.3 {DefaultSelection procedure} unix {
lappend result [dobg {lsort [selection get -type TARGETS]}]
cleanupbg
set result
-} {{MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}}
-test select-12.4 {DefaultSelection procedure} unix {
+} -result {{MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}}
+test select-12.4 {DefaultSelection procedure} -constraints unix -setup {
setup
set result ""
+} -body {
lappend result [selection get -type TK_APPLICATION]
setupbg
lappend result [dobg {selection get -type TK_APPLICATION}]
cleanupbg
set result
-} [list [winfo name .] [winfo name .]]
-test select-12.5 {DefaultSelection procedure} unix {
+} -result [list [winfo name .] [winfo name .]]
+test select-12.5 {DefaultSelection procedure} -constraints unix -body {
setup
set result [selection get -type TK_WINDOW]
setupbg
lappend result [dobg {selection get -type TK_WINDOW}]
cleanupbg
set result
-} {.f1 .f1}
-test select-12.6 {DefaultSelection procedure} {
+} -result {.f1 .f1}
+test select-12.6 {DefaultSelection procedure} -body {
setup
selection handle .f1 {handler TARGETS.f1} TARGETS
set selValue "Targets value"
@@ -1014,24 +1044,28 @@ test select-12.6 {DefaultSelection procedure} {
set result [list [selection get TARGETS] $selInfo]
selection handle .f1 {} TARGETS
lappend result [selection get TARGETS]
-} {{Targets value} {TARGETS.f1 0 4000} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}}
+} -result {{Targets value} {TARGETS.f1 0 4000} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}}
-test select-13.1 {SelectionSize procedure, handler deleted} unix {
- proc badHandler {path type offset count} {
- global selValue selInfo abortCount
- incr abortCount -1
- if {$abortCount == 0} {
- selection handle -type $type $path {}
- }
- lappend selInfo $path $type $offset $count
- set numBytes [expr {[string length $selValue] - $offset}]
- if {$numBytes <= 0} {
- return ""
- }
- string range $selValue $offset [expr $numBytes+$offset]
- }
+
+test select-13.1 {SelectionSize procedure, handler deleted} -constraints {
+ unix
+} -setup {
setup
setupbg
+} -body {
+ proc badHandler {path type offset count} {
+ global selValue selInfo abortCount
+ incr abortCount -1
+ if {$abortCount == 0} {
+ selection handle -type $type $path {}
+ }
+ lappend selInfo $path $type $offset $count
+ set numBytes [expr {[string length $selValue] - $offset}]
+ if {$numBytes <= 0} {
+ return ""
+ }
+ string range $selValue $offset [expr $numBytes+$offset]
+ }
set selValue $longValue
set selInfo ""
selection handle .f1 {badHandler .f1 STRING}
@@ -1040,10 +1074,11 @@ test select-13.1 {SelectionSize procedure, handler deleted} unix {
lappend result [dobg {selection get}]
cleanupbg
lappend result $selInfo
-} {{PRIMARY selection doesn't exist or form "STRING" not defined} {.f1 STRING 0 4000 .f1 STRING 4000 4000}}
+} -result {{PRIMARY selection doesn't exist or form "STRING" not defined} {.f1 STRING 0 4000 .f1 STRING 4000 4000}}
catch {rename weirdHandler {}}
# cleanup
cleanupTests
return
+
diff --git a/tests/textBTree.test b/tests/textBTree.test
index ed9762e..fc13817 100644
--- a/tests/textBTree.test
+++ b/tests/textBTree.test
@@ -8,644 +8,850 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: textBTree.test,v 1.7 2004/05/23 17:34:49 dkf Exp $
+# RCS: @(#) $Id: textBTree.test,v 1.8 2008/08/28 08:52:06 aniap Exp $
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
-catch {destroy .t}
+proc setup {} {
+ .t delete 1.0 100000.0
+ .t tag delete x y
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ .t tag add x 1.1
+ .t tag add x 1.5 1.13
+ .t tag add x 2.2 2.6
+ .t tag add y 1.5
+}
+
+# setup procedure for tests 10.*, 11.*, 12.*
+proc msetup {} {
+ .t delete 1.0 100000.0
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ .t mark set m1 1.2
+ .t mark set l1 1.2
+ .t mark gravity l1 left
+ .t mark set next 1.6
+ .t mark set x 1.6
+ .t mark set m2 2.0
+ .t mark set m3 2.100
+ .t tag add x 1.3 1.8
+}
+
+# setup procedure for tests 16.*, 17.*, 18.9
+proc setupBig {} {
+ .t delete 1.0 end
+ .t tag delete x y
+ .t tag configure x -foreground blue
+ .t tag configure y -underline true
+ # Create a Btree with 2002 lines (2000 + already existing + phantom at end)
+ # This generates a level 3 node with 9 children
+ # Most level 2 nodes cover 216 lines and have 6 children, except the last
+ # level 2 node covers 274 lines and has 7 children.
+ # Most level 1 nodes cover 36 lines and have 6 children, except the
+ # rightmost node has 58 lines and 9 children.
+ # Level 2: 2002 = 8*216 + 274
+ # Level 1: 2002 = 54*36 + 58
+ # Level 0: 2002 = 332*6 + 10
+ for {set i 0} {$i < 2000} {incr i} {
+ append x "Line $i abcd efgh ijkl\n"
+ }
+ .t insert insert $x
+ .t debug 1
+}
+
+# Widget used in tests 1.* - 13.*
+destroy .t
text .t
.t debug on
-test btree-1.1 {basic insertions} {
+test btree-1.1 {basic insertions} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t get 1.0 1000000.0
-} "Line 1\nLine 2\nLine 3\n"
-test btree-1.2 {basic insertions} {
+} -result "Line 1\nLine 2\nLine 3\n"
+test btree-1.2 {basic insertions} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t insert 1.3 XXX
.t get 1.0 1000000.0
-} "LinXXXe 1\nLine 2\nLine 3\n"
-test btree-1.3 {basic insertions} {
+} -result "LinXXXe 1\nLine 2\nLine 3\n"
+test btree-1.3 {basic insertions} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t insert 3.0 YYY
.t get 1.0 1000000.0
-} "Line 1\nLine 2\nYYYLine 3\n"
-test btree-1.4 {basic insertions} {
+} -result "Line 1\nLine 2\nYYYLine 3\n"
+test btree-1.4 {basic insertions} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t insert 2.1 X\nYY
.t get 1.0 1000000.0
-} "Line 1\nLX\nYYine 2\nLine 3\n"
-test btree-1.5 {basic insertions} {
+} -result "Line 1\nLX\nYYine 2\nLine 3\n"
+test btree-1.5 {basic insertions} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t insert 2.0 X\n\n\n
.t get 1.0 1000000.0
-} "Line 1\nX\n\n\nLine 2\nLine 3\n"
-test btree-1.6 {basic insertions} {
+} -result "Line 1\nX\n\n\nLine 2\nLine 3\n"
+test btree-1.6 {basic insertions} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t insert 2.6 X\n
.t get 1.0 1000000.0
-} "Line 1\nLine 2X\n\nLine 3\n"
-test btree-1.7 {insertion before start of text} {
+} -result "Line 1\nLine 2X\n\nLine 3\n"
+test btree-1.7 {insertion before start of text} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t insert 0.4 XXX
.t get 1.0 1000000.0
-} "XXXLine 1\nLine 2\nLine 3\n"
-test btree-1.8 {insertion past end of text} {
+} -result "XXXLine 1\nLine 2\nLine 3\n"
+test btree-1.8 {insertion past end of text} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t insert 100.0 ZZ
.t get 1.0 1000000.0
-} "Line 1\nLine 2\nLine 3ZZ\n"
-test btree-1.9 {insertion before start of line} {
+} -result "Line 1\nLine 2\nLine 3ZZ\n"
+test btree-1.9 {insertion before start of line} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t insert 2.-3 Q
.t get 1.0 1000000.0
-} "Line 1\nQLine 2\nLine 3\n"
-test btree-1.10 {insertion past end of line} {
+} -result "Line 1\nQLine 2\nLine 3\n"
+test btree-1.10 {insertion past end of line} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t insert 2.40 XYZZY
.t get 1.0 1000000.0
-} "Line 1\nLine 2XYZZY\nLine 3\n"
-test btree-1.11 {insertion past end of last line} {
+} -result "Line 1\nLine 2XYZZY\nLine 3\n"
+test btree-1.11 {insertion past end of last line} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t insert 3.40 ABC
.t get 1.0 1000000.0
-} "Line 1\nLine 2\nLine 3ABC\n"
+} -result "Line 1\nLine 2\nLine 3ABC\n"
+
-test btree-2.1 {basic deletions} {
+test btree-2.1 {basic deletions} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 1.0 1.3
.t get 1.0 1000000.0
-} "e 1\nLine 2\nLine 3\n"
-test btree-2.2 {basic deletions} {
+} -result "e 1\nLine 2\nLine 3\n"
+test btree-2.2 {basic deletions} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 2.2
.t get 1.0 1000000.0
-} "Line 1\nLie 2\nLine 3\n"
-test btree-2.3 {basic deletions} {
+} -result "Line 1\nLie 2\nLine 3\n"
+test btree-2.3 {basic deletions} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 2.0 2.3
.t get 1.0 1000000.0
-} "Line 1\ne 2\nLine 3\n"
-test btree-2.4 {deleting whole lines} {
+} -result "Line 1\ne 2\nLine 3\n"
+test btree-2.4 {deleting whole lines} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 1.2 3.0
.t get 1.0 1000000.0
-} "LiLine 3\n"
-test btree-2.5 {deleting whole lines} {
+} -result "LiLine 3\n"
+test btree-2.5 {deleting whole lines} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\n\n\nLine 5"
.t delete 1.0 5.2
.t get 1.0 1000000.0
-} "ne 5\n"
-test btree-2.6 {deleting before start of file} {
+} -result "ne 5\n"
+test btree-2.6 {deleting before start of file} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 0.3 1.2
.t get 1.0 1000000.0
-} "ne 1\nLine 2\nLine 3\n"
-test btree-2.7 {deleting after end of file} {
+} -result "ne 1\nLine 2\nLine 3\n"
+test btree-2.7 {deleting after end of file} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 10.3
.t get 1.0 1000000.0
-} "Line 1\nLine 2\nLine 3\n"
-test btree-2.8 {deleting before start of line} {
+} -result "Line 1\nLine 2\nLine 3\n"
+test btree-2.8 {deleting before start of line} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 3.-1 3.3
.t get 1.0 1000000.0
-} "Line 1\nLine 2\ne 3\n"
-test btree-2.9 {deleting before start of line} {
+} -result "Line 1\nLine 2\ne 3\n"
+test btree-2.9 {deleting before start of line} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 1.-1 1.0
.t get 1.0 1000000.0
-} "Line 1\nLine 2\nLine 3\n"
-test btree-2.10 {deleting after end of line} {
+} -result "Line 1\nLine 2\nLine 3\n"
+test btree-2.10 {deleting after end of line} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 1.8 2.1
.t get 1.0 1000000.0
-} "Line 1ine 2\nLine 3\n"
-test btree-2.11 {deleting after end of last line} {
+} -result "Line 1ine 2\nLine 3\n"
+test btree-2.11 {deleting after end of last line} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 3.8 4.1
.t get 1.0 1000000.0
-} "Line 1\nLine 2\nLine 3\n"
-test btree-2.12 {deleting before start of file} {
+} -result "Line 1\nLine 2\nLine 3\n"
+test btree-2.12 {deleting before start of file} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 1.8 0.0
.t get 1.0 1000000.0
-} "Line 1\nLine 2\nLine 3\n"
-test btree-2.13 {deleting past end of file} {
+} -result "Line 1\nLine 2\nLine 3\n"
+test btree-2.13 {deleting past end of file} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 1.8 4.0
.t get 1.0 1000000.0
-} "Line 1\n"
-test btree-2.14 {deleting with end before start of line} {
+} -result "Line 1\n"
+test btree-2.14 {deleting with end before start of line} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 1.3 2.-3
.t get 1.0 1000000.0
-} "LinLine 2\nLine 3\n"
-test btree-2.15 {deleting past end of line} {
+} -result "LinLine 2\nLine 3\n"
+test btree-2.15 {deleting past end of line} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 1.3 1.9
.t get 1.0 1000000.0
-} "Lin\nLine 2\nLine 3\n"
-test btree-2.16 {deleting past end of line} {
+} -result "Lin\nLine 2\nLine 3\n"
+test btree-2.16 {deleting past end of line} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 3.2 3.15
.t get 1.0 1000000.0
-} "Line 1\nLine 2\nLi\n"
-test btree-2.17 {deleting past end of line} {
+} -result "Line 1\nLine 2\nLi\n"
+test btree-2.17 {deleting past end of line} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 3.0 3.15
.t get 1.0 1000000.0
-} "Line 1\nLine 2\n\n"
-test btree-2.18 {deleting past end of line} {
+} -result "Line 1\nLine 2\n\n"
+test btree-2.18 {deleting past end of line} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 1.0 3.15
.t get 1.0 1000000.0
-} "\n"
-test btree-2.19 {deleting with negative range} {
+} -result "\n"
+test btree-2.19 {deleting with negative range} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 3.2 2.4
.t get 1.0 1000000.0
-} "Line 1\nLine 2\nLine 3\n"
-test btree-2.20 {deleting with negative range} {
+} -result "Line 1\nLine 2\nLine 3\n"
+test btree-2.20 {deleting with negative range} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 3.2 3.1
.t get 1.0 1000000.0
-} "Line 1\nLine 2\nLine 3\n"
-test btree-2.21 {deleting with negative range} {
+} -result "Line 1\nLine 2\nLine 3\n"
+test btree-2.21 {deleting with negative range} -body {
.t delete 1.0 100000.0
.t insert 1.0 "Line 1\nLine 2\nLine 3"
.t delete 3.2 3.2
.t get 1.0 1000000.0
-} "Line 1\nLine 2\nLine 3\n"
+} -result "Line 1\nLine 2\nLine 3\n"
-proc setup {} {
- .t delete 1.0 100000.0
- .t tag delete x y
- .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
- .t tag add x 1.1
- .t tag add x 1.5 1.13
- .t tag add x 2.2 2.6
- .t tag add y 1.5
-}
-test btree-3.1 {inserting with tags} {
+test btree-3.1 {inserting with tags} -body {
setup
.t insert 1.0 XXX
list [.t tag ranges x] [.t tag ranges y]
-} {{1.4 1.5 1.8 1.16 2.2 2.6} {1.8 1.9}}
-test btree-3.2 {inserting with tags} {
+} -result {{1.4 1.5 1.8 1.16 2.2 2.6} {1.8 1.9}}
+test btree-3.2 {inserting with tags} -body {
setup
.t insert 1.15 YYY
list [.t tag ranges x] [.t tag ranges y]
-} {{1.1 1.2 1.5 1.13 2.2 2.6} {1.5 1.6}}
-test btree-3.3 {inserting with tags} {
+} -result {{1.1 1.2 1.5 1.13 2.2 2.6} {1.5 1.6}}
+test btree-3.3 {inserting with tags} -body {
setup
.t insert 1.7 ZZZZ
list [.t tag ranges x] [.t tag ranges y]
-} {{1.1 1.2 1.5 1.17 2.2 2.6} {1.5 1.6}}
-test btree-3.4 {inserting with tags} {
+} -result {{1.1 1.2 1.5 1.17 2.2 2.6} {1.5 1.6}}
+test btree-3.4 {inserting with tags} -body {
setup
.t insert 1.7 \n\n
list [.t tag ranges x] [.t tag ranges y]
-} {{1.1 1.2 1.5 3.6 4.2 4.6} {1.5 1.6}}
-test btree-3.5 {inserting with tags} {
+} -result {{1.1 1.2 1.5 3.6 4.2 4.6} {1.5 1.6}}
+test btree-3.5 {inserting with tags} -body {
setup
.t insert 1.5 A\n
list [.t tag ranges x] [.t tag ranges y]
-} {{1.1 1.2 2.0 2.8 3.2 3.6} {2.0 2.1}}
-test btree-3.6 {inserting with tags} {
+} -result {{1.1 1.2 2.0 2.8 3.2 3.6} {2.0 2.1}}
+test btree-3.6 {inserting with tags} -body {
setup
.t insert 1.13 A\n
list [.t tag ranges x] [.t tag ranges y]
-} {{1.1 1.2 1.5 1.13 3.2 3.6} {1.5 1.6}}
+} -result {{1.1 1.2 1.5 1.13 3.2 3.6} {1.5 1.6}}
+
-test btree-4.1 {deleting with tags} {
+test btree-4.1 {deleting with tags} -body {
setup
.t delete 1.6 1.9
list [.t tag ranges x] [.t tag ranges y]
-} {{1.1 1.2 1.5 1.10 2.2 2.6} {1.5 1.6}}
-test btree-4.2 {deleting with tags} {
+} -result {{1.1 1.2 1.5 1.10 2.2 2.6} {1.5 1.6}}
+test btree-4.2 {deleting with tags} -body {
setup
.t delete 1.1 2.3
list [.t tag ranges x] [.t tag ranges y]
-} {{1.1 1.4} {}}
-test btree-4.3 {deleting with tags} {
+} -result {{1.1 1.4} {}}
+test btree-4.3 {deleting with tags} -body {
setup
.t delete 1.4 2.1
list [.t tag ranges x] [.t tag ranges y]
-} {{1.1 1.2 1.5 1.9} {}}
-test btree-4.4 {deleting with tags} {
+} -result {{1.1 1.2 1.5 1.9} {}}
+test btree-4.4 {deleting with tags} -body {
setup
.t delete 1.14 2.1
list [.t tag ranges x] [.t tag ranges y]
-} {{1.1 1.2 1.5 1.13 1.15 1.19} {1.5 1.6}}
-test btree-4.5 {deleting with tags} {
+} -result {{1.1 1.2 1.5 1.13 1.15 1.19} {1.5 1.6}}
+test btree-4.5 {deleting with tags} -body {
setup
.t delete 1.0 2.10
list [.t tag ranges x] [.t tag ranges y]
-} {{} {}}
-test btree-4.6 {deleting with tags} {
+} -result {{} {}}
+test btree-4.6 {deleting with tags} -body {
setup
.t delete 1.0 1.5
list [.t tag ranges x] [.t tag ranges y]
-} {{1.0 1.8 2.2 2.6} {1.0 1.1}}
-test btree-4.7 {deleting with tags} {
+} -result {{1.0 1.8 2.2 2.6} {1.0 1.1}}
+test btree-4.7 {deleting with tags} -body {
setup
.t delete 1.6 1.9
list [.t tag ranges x] [.t tag ranges y]
-} {{1.1 1.2 1.5 1.10 2.2 2.6} {1.5 1.6}}
-test btree-4.8 {deleting with tags} {
+} -result {{1.1 1.2 1.5 1.10 2.2 2.6} {1.5 1.6}}
+test btree-4.8 {deleting with tags} -body {
setup
.t delete 1.5 1.13
list [.t tag ranges x] [.t tag ranges y]
-} {{1.1 1.2 2.2 2.6} {}}
+} -result {{1.1 1.2 2.2 2.6} {}}
-set bigText1 {}
-for {set i 0} {$i < 10} {incr i} {
- append bigText1 "Line $i\n"
-}
-set bigText2 {}
-for {set i 0} {$i < 200} {incr i} {
- append bigText2 "Line $i\n"
-}
-test btree-5.1 {very large inserts, with tags} {
+
+test btree-5.1 {very large inserts, with tags} -setup {
+ set bigText1 {}
+ for {set i 0} {$i < 10} {incr i} {
+ append bigText1 "Line $i\n"
+ }
+} -body {
setup
.t insert 1.0 $bigText1
list [.t tag ranges x] [.t tag ranges y]
-} {{11.1 11.2 11.5 11.13 12.2 12.6} {11.5 11.6}}
-test btree-5.2 {very large inserts, with tags} {
+} -result {{11.1 11.2 11.5 11.13 12.2 12.6} {11.5 11.6}}
+test btree-5.2 {very large inserts, with tags} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
setup
.t insert 1.2 $bigText2
list [.t tag ranges x] [.t tag ranges y]
-} {{1.1 1.2 201.3 201.11 202.2 202.6} {201.3 201.4}}
-test btree-5.3 {very large inserts, with tags} {
+} -result {{1.1 1.2 201.3 201.11 202.2 202.6} {201.3 201.4}}
+test btree-5.3 {very large inserts, with tags} -body {
setup
for {set i 0} {$i < 200} {incr i} {
- .t insert 1.8 "longer line $i\n"
+ .t insert 1.8 "longer line $i\n"
}
- list [.t tag ranges x] [.t tag ranges y] [.t get 1.0 1.100] [.t get 198.0 198.100]
-} {{1.1 1.2 1.5 201.5 202.2 202.6} {1.5 1.6} {Text forlonger line 199} {longer line 2}}
+ list [.t tag ranges x] [.t tag ranges y] [.t get 1.0 1.100] \
+ [.t get 198.0 198.100]
+} -result {{1.1 1.2 1.5 201.5 202.2 202.6} {1.5 1.6} {Text forlonger line 199} {longer line 2}}
-test btree-6.1 {very large deletes, with tags} {
+
+test btree-6.1 {very large deletes, with tags} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
setup
.t insert 1.1 $bigText2
.t delete 1.2 201.2
list [.t tag ranges x] [.t tag ranges y]
-} {{1.4 1.12 2.2 2.6} {1.4 1.5}}
-test btree-6.2 {very large deletes, with tags} {
+} -result {{1.4 1.12 2.2 2.6} {1.4 1.5}}
+test btree-6.2 {very large deletes, with tags} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
setup
.t insert 1.1 $bigText2
for {set i 0} {$i < 200} {incr i} {
- .t delete 1.2 2.2
+ .t delete 1.2 2.2
}
list [.t tag ranges x] [.t tag ranges y]
-} {{1.4 1.12 2.2 2.6} {1.4 1.5}}
-test btree-6.3 {very large deletes, with tags} {
+} -result {{1.4 1.12 2.2 2.6} {1.4 1.5}}
+test btree-6.3 {very large deletes, with tags} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
setup
.t insert 1.1 $bigText2
.t delete 2.3 10000.0
.t get 1.0 1000.0
-} {TLine 0
+} -result {TLine 0
Lin
}
-test btree-6.4 {very large deletes, with tags} {
+test btree-6.4 {very large deletes, with tags} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
setup
.t insert 1.1 $bigText2
for {set i 0} {$i < 100} {incr i} {
- .t delete 30.0 31.0
+ .t delete 30.0 31.0
}
list [.t tag ranges x] [.t tag ranges y]
-} {{101.0 101.1 101.4 101.12 102.2 102.6} {101.4 101.5}}
-test btree-6.5 {very large deletes, with tags} {
+} -result {{101.0 101.1 101.4 101.12 102.2 102.6} {101.4 101.5}}
+test btree-6.5 {very large deletes, with tags} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
setup
.t insert 1.1 $bigText2
for {set i 0} {$i < 100} {incr i} {
- set j [expr $i+2]
- set k [expr 1+2*$i]
- .t tag add x $j.1 $j.3
- .t tag add y $k.1 $k.6
+ set j [expr $i+2]
+ set k [expr 1+2*$i]
+ .t tag add x $j.1 $j.3
+ .t tag add y $k.1 $k.6
}
.t delete 2.0 200.0
list [.t tag ranges x] [.t tag ranges y]
-} {{3.0 3.1 3.4 3.12 4.2 4.6} {1.1 1.6 3.4 3.5}}
-test btree-6.6 {very large deletes, with tags} {
+} -result {{3.0 3.1 3.4 3.12 4.2 4.6} {1.1 1.6 3.4 3.5}}
+test btree-6.6 {very large deletes, with tags} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
setup
.t insert 1.1 $bigText2
for {set i 0} {$i < 100} {incr i} {
- set j [expr $i+2]
- set k [expr 1+2*$i]
- .t tag add x $j.1 $j.3
- .t tag add y $k.1 $k.6
+ set j [expr $i+2]
+ set k [expr 1+2*$i]
+ .t tag add x $j.1 $j.3
+ .t tag add y $k.1 $k.6
}
for {set i 199} {$i >= 2} {incr i -1} {
- .t delete $i.0 [expr $i+1].0
+ .t delete $i.0 [expr $i+1].0
}
list [.t tag ranges x] [.t tag ranges y]
-} {{3.0 3.1 3.4 3.12 4.2 4.6} {1.1 1.6 3.4 3.5}}
-
-.t delete 1.0 end
-.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
-set i 1
-foreach check {
- {1.3 1.6 1.7 2.0 {1.3 1.6 1.7 2.0}}
- {1.3 1.6 1.6 2.0 {1.3 2.0}}
- {1.3 1.6 1.4 2.0 {1.3 2.0}}
- {2.0 4.3 1.4 1.10 {1.4 1.10 2.0 4.3}}
- {2.0 4.3 1.4 1.end {1.4 1.19 2.0 4.3}}
- {2.0 4.3 1.4 2.0 {1.4 4.3}}
- {2.0 4.3 1.4 3.0 {1.4 4.3}}
- {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.1 4.2 {1.1 4.2}}
- {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.3 4.2 {1.2 4.2}}
- {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.1 3.0 {1.1 4.0}}
- {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.2 3.0 {1.2 4.0}}
-} {
- test btree-7.$i {tag addition and removal} {
- .t tag remove x 1.0 end
- while {[llength $check] > 2} {
- .t tag add x [lindex $check 0] [lindex $check 1]
- set check [lrange $check 2 end]
- }
- .t tag ranges x
- } [lindex $check [expr [llength $check]-1]]
- incr i
-}
+} -result {{3.0 3.1 3.4 3.12 4.2 4.6} {1.1 1.6 3.4 3.5}}
+
+
+test btree-7.1 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {1.3 1.6 1.7 2.0}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.3 1.6 1.7 2.0}
+test btree-7.2 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {1.3 1.6 1.6 2.0}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.3 2.0}
+test btree-7.3 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {1.3 1.6 1.4 2.0}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.3 2.0}
+test btree-7.4 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {2.0 4.3 1.4 1.10}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.4 1.10 2.0 4.3}
+test btree-7.5 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {2.0 4.3 1.4 1.end}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.4 1.19 2.0 4.3}
+test btree-7.6 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {2.0 4.3 1.4 2.0}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.4 4.3}
+test btree-7.7 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {2.0 4.3 1.4 3.0}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.4 4.3}
+test btree-7.8 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.1 4.2}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.1 4.2}
+test btree-7.9 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.3 4.2}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.2 4.2}
+test btree-7.10 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.1 3.0}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.1 4.0}
+test btree-7.11 {tag addition and removal} -setup {
+ .t delete 1.0 end
+ .t tag remove x 1.0 end
+} -body {
+ .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
+ set check {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.2 3.0}
+ while {[llength $check]} {
+ .t tag add x [lindex $check 0] [lindex $check 1]
+ set check [lrange $check 2 end]
+ }
+ .t tag ranges x
+} -result {1.2 4.0}
-test btree-8.1 {tag addition and removal, weird ranges} {
+
+test btree-8.1 {tag addition and removal, weird ranges} -body {
.t delete 1.0 100000.0
.t tag delete x
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 0.0 1.3
.t tag ranges x
-} {1.0 1.3}
-test btree-8.2 {tag addition and removal, weird ranges} {
+} -result {1.0 1.3}
+test btree-8.2 {tag addition and removal, weird ranges} -body {
.t delete 1.0 100000.0
.t tag delete x
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 1.40 2.4
.t tag ranges x
-} {1.19 2.4}
-test btree-8.3 {tag addition and removal, weird ranges} {
+} -result {1.19 2.4}
+test btree-8.3 {tag addition and removal, weird ranges} -body {
.t delete 1.0 100000.0
.t tag delete x
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 4.40 4.41
.t tag ranges x
-} {}
-test btree-8.4 {tag addition and removal, weird ranges} {
+} -result {}
+test btree-8.4 {tag addition and removal, weird ranges} -body {
.t delete 1.0 100000.0
.t tag delete x
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 5.1 5.2
.t tag ranges x
-} {}
-test btree-8.5 {tag addition and removal, weird ranges} {
+} -result {}
+test btree-8.5 {tag addition and removal, weird ranges} -body {
.t delete 1.0 100000.0
.t tag delete x
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 1.1 9.0
.t tag ranges x
-} {1.1 5.0}
-test btree-8.6 {tag addition and removal, weird ranges} {
+} -result {1.1 5.0}
+test btree-8.6 {tag addition and removal, weird ranges} -body {
.t delete 1.0 100000.0
.t tag delete x
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 1.1 1.90
.t tag ranges x
-} {1.1 1.19}
-test btree-8.7 {tag addition and removal, weird ranges} {
+} -result {1.1 1.19}
+test btree-8.7 {tag addition and removal, weird ranges} -body {
.t delete 1.0 100000.0
.t tag delete x
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 1.1 4.90
.t tag ranges x
-} {1.1 4.17}
-test btree-8.8 {tag addition and removal, weird ranges} {
+} -result {1.1 4.17}
+test btree-8.8 {tag addition and removal, weird ranges} -body {
.t delete 1.0 100000.0
.t tag delete x
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 3.0 3.0
.t tag ranges x
-} {}
+} -result {}
+
-test btree-9.1 {tag names} {
+test btree-9.1 {tag names} -body {
setup
.t tag names
-} {sel x y}
-test btree-9.2 {tag names} {
+} -result {sel x y}
+test btree-9.2 {tag names} -body {
setup
.t tag add tag1 1.8
.t tag add tag2 1.8
.t tag add tag3 1.7 1.9
.t tag names 1.8
-} {x tag1 tag2 tag3}
-test btree-9.3 {lots of tag names} {
+} -result {x tag1 tag2 tag3}
+test btree-9.3 {lots of tag names} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
setup
.t insert 1.2 $bigText2
foreach i {tag1 foo ThisOne {x space} q r s t} {
- .t tag add $i 150.2
+ .t tag add $i 150.2
}
foreach i {u tagA tagB tagC and more {$} \{} {
- .t tag add $i 150.1 150.3
+ .t tag add $i 150.1 150.3
}
.t tag names 150.2
-} {tag1 foo ThisOne {x space} q r s t u tagA tagB tagC and more {$} \{}
-test btree-9.4 {lots of tag names} {
+} -result {tag1 foo ThisOne {x space} q r s t u tagA tagB tagC and more {$} \{}
+test btree-9.4 {lots of tag names} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
setup
.t insert 1.2 $bigText2
.t tag delete tag1 foo ThisOne more {x space} q r s t u
.t tag delete tagA tagB tagC and {$} \{ more
foreach i {tag1 foo ThisOne more {x space} q r s t} {
- .t tag add $i 150.2
+ .t tag add $i 150.2
}
foreach i {foo ThisOne u tagA tagB tagC and more {$} \{} {
- .t tag add $i 150.4
+ .t tag add $i 150.4
}
.t tag delete tag1 more q r tagA
.t tag names 150.2
-} {foo ThisOne {x space} s t}
+} -result {foo ThisOne {x space} s t}
-proc msetup {} {
- .t delete 1.0 100000.0
- .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
- .t mark set m1 1.2
- .t mark set l1 1.2
- .t mark gravity l1 left
- .t mark set next 1.6
- .t mark set x 1.6
- .t mark set m2 2.0
- .t mark set m3 2.100
- .t tag add x 1.3 1.8
-}
-test btree-10.1 {basic mark facilities} {
+
+test btree-10.1 {basic mark facilities} -body {
msetup
list [lsort [.t mark names]] [.t index m1] [.t index m2] [.t index m3]
-} {{current insert l1 m1 m2 m3 next x} 1.2 2.0 2.11}
-test btree-10.2 {basic mark facilities} {
+} -result {{current insert l1 m1 m2 m3 next x} 1.2 2.0 2.11}
+test btree-10.2 {basic mark facilities} -body {
msetup
.t mark unset m2
lsort [.t mark names]
-} {current insert l1 m1 m3 next x}
-test btree-10.3 {basic mark facilities} {
+} -result {current insert l1 m1 m3 next x}
+test btree-10.3 {basic mark facilities} -body {
msetup
.t mark set m2 1.8
list [lsort [.t mark names]] [.t index m1] [.t index m2] [.t index m3]
-} {{current insert l1 m1 m2 m3 next x} 1.2 1.8 2.11}
+} -result {{current insert l1 m1 m2 m3 next x} 1.2 1.8 2.11}
-test btree-11.1 {marks and inserts} {
+
+test btree-11.1 {marks and inserts} -body {
msetup
.t insert 1.1 abcde
list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
-} {1.7 1.7 1.11 1.11 2.0 2.11}
-test btree-11.2 {marks and inserts} {
+} -result {1.7 1.7 1.11 1.11 2.0 2.11}
+test btree-11.2 {marks and inserts} -body {
msetup
.t insert 1.2 abcde
list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
-} {1.2 1.7 1.11 1.11 2.0 2.11}
-test btree-11.3 {marks and inserts} {
+} -result {1.2 1.7 1.11 1.11 2.0 2.11}
+test btree-11.3 {marks and inserts} -body {
msetup
.t insert 1.3 abcde
list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
-} {1.2 1.2 1.11 1.11 2.0 2.11}
-test btree-11.4 {marks and inserts} {
+} -result {1.2 1.2 1.11 1.11 2.0 2.11}
+test btree-11.4 {marks and inserts} -body {
msetup
.t insert 1.1 ab\n\ncde
list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
-} {3.4 3.4 3.8 3.8 4.0 4.11}
-test btree-11.5 {marks and inserts} {
+} -result {3.4 3.4 3.8 3.8 4.0 4.11}
+test btree-11.5 {marks and inserts} -body {
msetup
.t insert 1.4 ab\n\ncde
list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
-} {1.2 1.2 3.5 3.5 4.0 4.11}
-test btree-11.6 {marks and inserts} {
+} -result {1.2 1.2 3.5 3.5 4.0 4.11}
+test btree-11.6 {marks and inserts} -body {
msetup
.t insert 1.7 ab\n\ncde
list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
-} {1.2 1.2 1.6 1.6 4.0 4.11}
+} -result {1.2 1.2 1.6 1.6 4.0 4.11}
+
-test btree-12.1 {marks and deletes} {
+test btree-12.1 {marks and deletes} -body {
msetup
.t delete 1.3 1.5
list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
-} {1.2 1.2 1.4 1.4 2.0 2.11}
-test btree-12.2 {marks and deletes} {
+} -result {1.2 1.2 1.4 1.4 2.0 2.11}
+test btree-12.2 {marks and deletes} -body {
msetup
.t delete 1.3 1.8
list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
-} {1.2 1.2 1.3 1.3 2.0 2.11}
-test btree-12.3 {marks and deletes} {
+} -result {1.2 1.2 1.3 1.3 2.0 2.11}
+test btree-12.3 {marks and deletes} -body {
msetup
.t delete 1.2 1.8
list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
-} {1.2 1.2 1.2 1.2 2.0 2.11}
-test btree-12.4 {marks and deletes} {
+} -result {1.2 1.2 1.2 1.2 2.0 2.11}
+test btree-12.4 {marks and deletes} -body {
msetup
.t delete 1.1 1.8
list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
-} {1.1 1.1 1.1 1.1 2.0 2.11}
-test btree-12.5 {marks and deletes} {
+} -result {1.1 1.1 1.1 1.1 2.0 2.11}
+test btree-12.5 {marks and deletes} -body {
msetup
.t delete 1.5 3.1
list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
-} {1.2 1.2 1.5 1.5 1.5 1.5}
-test btree-12.6 {marks and deletes} {
+} -result {1.2 1.2 1.5 1.5 1.5 1.5}
+test btree-12.6 {marks and deletes} -body {
msetup
.t mark set m2 4.5
.t delete 1.5 4.1
list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
-} {1.2 1.2 1.5 1.5 1.9 1.5}
-test btree-12.7 {marks and deletes} {
+} -result {1.2 1.2 1.5 1.5 1.9 1.5}
+test btree-12.7 {marks and deletes} -body {
msetup
.t mark set m2 4.5
.t mark set m3 4.5
.t mark set m1 4.7
.t delete 1.5 4.1
list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3]
-} {1.2 1.11 1.5 1.5 1.9 1.9}
+} -result {1.2 1.11 1.5 1.5 1.9 1.9}
-destroy .t
-text .t
-test btree-13.1 {tag searching} {
+
+test btree-13.1 {tag searching} -setup {
.t delete 1.0 100000.0
+} -body {
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag next x 2.2 2.1
-} {}
-test btree-13.2 {tag searching} {
+} -result {}
+test btree-13.2 {tag searching} -setup {
.t delete 1.0 100000.0
+} -body {
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 2.2 2.4
.t tag next x 2.2 2.3
-} {2.2 2.4}
-test btree-13.3 {tag searching} {
+} -result {2.2 2.4}
+test btree-13.3 {tag searching} -setup {
.t delete 1.0 100000.0
+} -body {
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 2.2 2.4
.t tag next x 2.3 2.6
-} {}
-test btree-13.4 {tag searching} {
+} -result {}
+test btree-13.4 {tag searching} -setup {
.t delete 1.0 100000.0
+} -body {
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 2.5 2.8
.t tag next x 2.1 2.6
-} {2.5 2.8}
-test btree-13.5 {tag searching} {
+} -result {2.5 2.8}
+test btree-13.5 {tag searching} -setup {
.t delete 1.0 100000.0
+} -body {
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 2.5 2.8
.t tag next x 2.1 2.5
-} {}
-test btree-13.6 {tag searching} {
+} -result {}
+test btree-13.6 {tag searching} -setup {
.t delete 1.0 100000.0
+} -body {
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 2.1 2.4
.t tag next x 2.5 2.8
-} {}
-test btree-13.7 {tag searching} {
+} -result {}
+test btree-13.7 {tag searching} -setup {
.t delete 1.0 100000.0
+} -body {
.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
.t tag add x 2.5 2.8
.t tag next x 2.1 2.4
-} {}
-test btree-13.8 {tag searching} {
+} -result {}
+test btree-13.8 {tag searching} -setup {
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
setup
.t insert 1.2 $bigText2
.t tag add x 190.3 191.2
.t tag next x 3.5
-} {190.3 191.2}
+} -result {190.3 191.2}
+destroy .t
+
-test btree-14.1 {check tag presence} {
+test btree-14.1 {check tag presence} -setup {
+ destroy .t
+ text .t
+ set bigText2 {}
+ for {set i 0} {$i < 200} {incr i} {
+ append bigText2 "Line $i\n"
+ }
+} -body {
setup
.t insert 1.2 $bigText2
.t tag add x 3.5 3.7
@@ -658,242 +864,371 @@ test btree-14.1 {check tag presence} {
.t tag add b 7.5
.t tag add b 140.3
for {set i 120} {$i < 160} {incr i} {
- .t tag add c $i.4
+ .t tag add c $i.4
}
foreach i {a1 a2 a3 a4 a5 a6 a7 a8 a9 10 a11 a12 a13} {
- .t tag add $i 122.2
+ .t tag add $i 122.2
}
.t tag add x 141.3
.t tag names 141.1
-} {x y z}
+} -cleanup {
+ destroy .t
+} -result {x y z}
+
-test btree-15.1 {rebalance with empty node} {
- catch {destroy .t}
+test btree-15.1 {rebalance with empty node} -setup {
+ destroy .t
+} -body {
text .t
.t debug 1
.t insert end "1\n2\n3\n4\n5\n6\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17\n18\n19\n20\n21\n22\n23"
.t delete 6.0 12.0
.t get 1.0 end
-} "1\n2\n3\n4\n5\n12\n13\n14\n15\n16\n17\n18\n19\n20\n21\n22\n23\n"
+} -cleanup {
+ destroy .t
+} -result "1\n2\n3\n4\n5\n12\n13\n14\n15\n16\n17\n18\n19\n20\n21\n22\n23\n"
-proc setupBig {} {
- .t delete 1.0 end
- .t tag delete x y
- .t tag configure x -foreground blue
- .t tag configure y -underline true
- # Create a Btree with 2002 lines (2000 + already existing + phantom at end)
- # This generates a level 3 node with 9 children
- # Most level 2 nodes cover 216 lines and have 6 children, except the last
- # level 2 node covers 274 lines and has 7 children.
- # Most level 1 nodes cover 36 lines and have 6 children, except the
- # rightmost node has 58 lines and 9 children.
- # Level 2: 2002 = 8*216 + 274
- # Level 1: 2002 = 54*36 + 58
- # Level 0: 2002 = 332*6 + 10
- for {set i 0} {$i < 2000} {incr i} {
- append x "Line $i abcd efgh ijkl\n"
- }
- .t insert insert $x
- .t debug 1
-}
-test btree-16.1 {add tag does not push root above level 0} {
- catch {destroy .t}
+test btree-16.1 {add tag does not push root above level 0} -setup {
+ destroy .t
text .t
+} -body {
setupBig
+ .t debug 0
.t tag add x 1.1 1.10
.t tag add x 5.1 5.10
.t tag ranges x
-} {1.1 1.10 5.1 5.10}
-test btree-16.2 {add tag pushes root up to level 1 node} {
- catch {destroy .t}
+} -cleanup {
+ destroy .t
+} -result {1.1 1.10 5.1 5.10}
+test btree-16.2 {add tag pushes root up to level 1 node} -setup {
+ destroy .t
text .t
- .t debug 1
+} -body {
setupBig
.t tag add x 1.1 1.10
.t tag add x 8.1 8.10
.t tag ranges x
-} {1.1 1.10 8.1 8.10}
-test btree-16.3 {add tag pushes root up to level 2 node} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {1.1 1.10 8.1 8.10}
+test btree-16.3 {add tag pushes root up to level 2 node} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
.t tag add x 8.1 9.10
.t tag add x 180.1 180.end
.t tag ranges x
-} {8.1 9.10 180.1 180.23}
-test btree-16.4 {add tag pushes root up to level 3 node} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {8.1 9.10 180.1 180.23}
+test btree-16.4 {add tag pushes root up to level 3 node} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
.t tag add y 1.1 2000.0
.t tag add x 1.1 8.10
.t tag add x 180.end 217.0
list [.t tag ranges x] [.t tag ranges y]
-} {{1.1 8.10 180.23 217.0} {1.1 2000.0}}
-test btree-16.5 {add tag doesn't push root up} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {{1.1 8.10 180.23 217.0} {1.1 2000.0}}
+test btree-16.5 {add tag doesn't push root up} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
.t tag add x 1.1 8.10
.t tag add x 2000.0 2000.3
.t tag add x 180.end 217.0
.t tag ranges x
-} {1.1 8.10 180.23 217.0 2000.0 2000.3}
-test btree-16.6 {two node splits at once pushes root up} {
- .t delete 1.0 end
+} -cleanup {
+ destroy .t
+} -result {1.1 8.10 180.23 217.0 2000.0 2000.3}
+test btree-16.6 {two node splits at once pushes root up} -setup {
+ destroy .t
+ text .t
+} -body {
for {set i 1} {$i < 10} {incr i} {
- .t insert end "Line $i\n"
+ .t insert end "Line $i\n"
}
.t tag add x 8.0 8.end
.t tag add y 9.0 end
set x {}
for {} {$i < 50} {incr i} {
- append x "Line $i\n"
+ append x "Line $i\n"
}
.t insert end $x y
list [.t tag ranges x] [.t tag ranges y]
-} {{8.0 8.6} {9.0 51.0}}
+} -cleanup {
+ destroy .t
+} -result {{8.0 8.6} {9.0 51.0}}
# The following find bugs in the SearchStart procedures
-test btree-16.7 {Partial tag remove from before first range} {
- .t tag remove x 1.0 end
+test btree-16.7 {Partial tag remove from before first range} -setup {
+ destroy .t
+ text .t
+ for {set i 1} {$i < 10} {incr i} {
+ .t insert end "Line $i\n"
+ }
+} -body {
.t tag add x 2.0 2.6
.t tag remove x 1.0 2.0
.t tag ranges x
-} {2.0 2.6}
-test btree-16.8 {Partial tag remove from before first range} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {2.0 2.6}
+test btree-16.8 {Partial tag remove from before first range} -setup {
+ destroy .t
+ text .t
+ for {set i 1} {$i < 10} {incr i} {
+ .t insert end "Line $i\n"
+ }
+} -body {
.t tag add x 2.0 2.6
.t tag remove x 1.0 2.1
.t tag ranges x
-} {2.1 2.6}
-test btree-16.9 {Partial tag remove from before first range} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {2.1 2.6}
+test btree-16.9 {Partial tag remove from before first range} -setup {
+ destroy .t
+ text .t
+ for {set i 1} {$i < 10} {incr i} {
+ .t insert end "Line $i\n"
+ }
+} -body {
.t tag add x 2.0 2.6
.t tag remove x 1.0 2.3
.t tag ranges x
-} {2.3 2.6}
-test btree-16.10 {Partial tag remove from before first range} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {2.3 2.6}
+test btree-16.10 {Partial tag remove from before first range} -setup {
+ destroy .t
+ text .t
+ for {set i 1} {$i < 10} {incr i} {
+ .t insert end "Line $i\n"
+ }
+} -body {
.t tag add x 1.0 2.6
.t tag remove x 1.0 2.5
.t tag ranges x
-} {2.5 2.6}
-test btree-16.11 {StartSearchBack boundary case} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {2.5 2.6}
+test btree-16.11 {StartSearchBack boundary case} -setup {
+ destroy .t
+ text .t
+ for {set i 1} {$i < 10} {incr i} {
+ .t insert end "Line $i\n"
+ }
+} -body {
.t tag add x 1.3 1.4
.t tag prevr x 2.0 1.4
-} {}
-test btree-16.12 {StartSearchBack boundary case} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {}
+test btree-16.12 {StartSearchBack boundary case} -setup {
+ destroy .t
+ text .t
+ for {set i 1} {$i < 10} {incr i} {
+ .t insert end "Line $i\n"
+ }
+} -body {
.t tag add x 1.3 1.4
.t tag prevr x 2.0 1.3
-} {1.3 1.4}
-test btree-16.13 {StartSearchBack boundary case} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {1.3 1.4}
+test btree-16.13 {StartSearchBack boundary case} -setup {
+ destroy .t
+ text .t
+ for {set i 1} {$i < 10} {incr i} {
+ .t insert end "Line $i\n"
+ }
+} -body {
.t tag add x 1.0 1.4
.t tag prevr x 1.3
-} {1.0 1.4}
+} -cleanup {
+ destroy .t
+} -result {1.0 1.4}
-test btree-17.1 {remove tag does not push root down} {
- catch {destroy .t}
+test btree-17.1 {remove tag does not push root down} -setup {
+ destroy .t
text .t
+} -body {
.t debug 0
setupBig
.t tag add x 1.1 5.10
.t tag remove x 3.1 5.end
.t tag ranges x
-} {1.1 3.1}
-test btree-17.2 {remove tag pushes root from level 1 to level 0} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {1.1 3.1}
+test btree-17.2 {remove tag pushes root from level 1 to level 0} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
.t tag add x 1.1 8.10
.t tag remove x 3.1 end
.t tag ranges x
-} {1.1 3.1}
-test btree-17.3 {remove tag pushes root from level 2 to level 1} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {1.1 3.1}
+test btree-17.3 {remove tag pushes root from level 2 to level 1} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
.t tag add x 1.1 180.10
.t tag remove x 35.1 end
.t tag ranges x
-} {1.1 35.1}
-test btree-17.4 {remove tag doesn't change level 2} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {1.1 35.1}
+test btree-17.4 {remove tag doesn't change level 2} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
.t tag add x 1.1 180.10
.t tag remove x 35.1 180.0
.t tag ranges x
-} {1.1 35.1 180.0 180.10}
-test btree-17.5 {remove tag pushes root from level 3 to level 0} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {1.1 35.1 180.0 180.10}
+test btree-17.5 {remove tag pushes root from level 3 to level 0} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
.t tag add x 1.1 1.10
.t tag add x 2000.1 2000.10
.t tag remove x 1.0 2000.0
.t tag ranges x
-} {2000.1 2000.10}
-test btree-17.6 {text deletion pushes root from level 3 to level 0} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {2000.1 2000.10}
+test btree-17.6 {text deletion pushes root from level 3 to level 0} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
.t tag add x 1.1 1.10
.t tag add x 2000.1 2000.10
.t delete 1.0 "1000.0 lineend +1 char"
.t tag ranges x
-} {1000.1 1000.10}
+} -cleanup {
+ destroy .t
+} -result {1000.1 1000.10}
-catch {destroy .t}
-text .t
-test btree-18.1 {tag search back, no tag} {
+
+test btree-18.1 {tag search back, no tag} -setup {
+ destroy .t
+ text .t
+} -body {
.t insert 1.0 "Line 1 abcd efgh ijkl\n"
.t tag prev x 1.1 1.1
-} {}
-test btree-18.2 {tag search back, start at existing range} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {}
+test btree-18.2 {tag search back, start at existing range} -setup {
+ destroy .t
+ text .t
+} -body {
+ .t insert 1.0 "Line 1 abcd efgh ijkl\n"
.t tag add x 1.1 1.4
.t tag add x 1.8 1.11
.t tag add x 1.16
.t tag prev x 1.1
-} {}
-test btree-18.3 {tag search back, end at existing range} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {}
+test btree-18.3 {tag search back, end at existing range} -setup {
+ destroy .t
+ text .t
+} -body {
+ .t insert 1.0 "Line 1 abcd efgh ijkl\n"
.t tag add x 1.1 1.4
.t tag add x 1.8 1.11
.t tag add x 1.16
.t tag prev x 1.3 1.1
-} {1.1 1.4}
-test btree-18.4 {tag search back, start within range} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {1.1 1.4}
+test btree-18.4 {tag search back, start within range} -setup {
+ destroy .t
+ text .t
+} -body {
+ .t insert 1.0 "Line 1 abcd efgh ijkl\n"
.t tag add x 1.1 1.4
.t tag add x 1.8 1.11
.t tag add x 1.16
.t tag prev x 1.10 1.0
-} {1.8 1.11}
-test btree-18.5 {tag search back, start at end of range} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {1.8 1.11}
+test btree-18.5 {tag search back, start at end of range} -setup {
+ destroy .t
+ text .t
+} -body {
+ .t insert 1.0 "Line 1 abcd efgh ijkl\n"
.t tag add x 1.1 1.4
.t tag add x 1.8 1.11
.t tag add x 1.16
list [.t tag prev x 1.4 1.0] [.t tag prev x 1.11 1.0]
-} {{1.1 1.4} {1.8 1.11}}
-test btree-18.6 {tag search back, start beyond range, same level 0 node} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {{1.1 1.4} {1.8 1.11}}
+test btree-18.6 {tag search back, start beyond range, same level 0 node} -setup {
+ destroy .t
+ text .t
+} -body {
+ .t insert 1.0 "Line 1 abcd efgh ijkl\n"
.t tag add x 1.1 1.4
.t tag add x 1.8 1.11
.t tag add x 1.16
.t tag prev x 3.0
-} {1.16 1.17}
-test btree-18.7 {tag search back, outside any range} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {1.16 1.17}
+test btree-18.7 {tag search back, outside any range} -setup {
+ destroy .t
+ text .t
+} -body {
+ .t insert 1.0 "Line 1 abcd efgh ijkl\n"
.t tag add x 1.1 1.4
.t tag add x 1.16
.t tag prev x 1.8 1.5
-} {}
-test btree-18.8 {tag search back, start at start of node boundary} {
+} -cleanup {
+ destroy .t
+} -result {}
+test btree-18.8 {tag search back, start at start of node boundary} -setup {
+ destroy .t
+ text .t
+} -body {
setupBig
- .t tag remove x 1.0 end
.t tag add x 2.5 2.8
.t tag prev x 19.0
-} {2.5 2.8}
-test btree-18.9 {tag search back, large complex btree spans} {
- .t tag remove x 1.0 end
+} -cleanup {
+ destroy .t
+} -result {2.5 2.8}
+test btree-18.9 {tag search back, large complex btree spans} -setup {
+ destroy .t
+ text .t
+} -body {
+ setupBig
.t tag add x 1.3 1.end
.t tag add x 200.0 220.0
.t tag add x 500.0 520.0
list [.t tag prev x end] [.t tag prev x 433.0]
-} {{500.0 520.0} {200.0 220.0}}
-
-destroy .t
+} -cleanup {
+ destroy .t
+} -result {{500.0 520.0} {200.0 220.0}}
# cleanup
cleanupTests
diff --git a/tests/textImage.test b/tests/textImage.test
index d78472a..e0fc05b 100644
--- a/tests/textImage.test
+++ b/tests/textImage.test
@@ -7,351 +7,446 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: textImage.test,v 1.11 2008/07/23 23:24:25 nijtmans Exp $
+# RCS: @(#) $Id: textImage.test,v 1.12 2008/08/28 08:52:06 aniap Exp $
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
# One time setup. Create a font to insure the tests are font metric invariant.
-
-catch {destroy .t}
+destroy .t
font create test_font -family courier -size 14
text .t -font test_font
destroy .t
-test textImage-1.1 {basic argument checking} {
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image} msg] $msg
-} {1 {wrong # args: should be ".t image option ?arg ...?"}}
-
-test textImage-1.2 {basic argument checking} {
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image c} msg] $msg
-} {1 {ambiguous option "c": must be cget, configure, create, or names}}
-
-test textImage-1.3 {cget argument checking} {
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image cget} msg] $msg
-} {1 {wrong # args: should be ".t image cget index option"}}
-
-test textImage-1.4 {cget argument checking} {
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image cget blurf -flurp} msg] $msg
-} {1 {bad text index "blurf"}}
-
-test textImage-1.5 {cget argument checking} {
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image cget 1.1 -flurp} msg] $msg
-} {1 {no embedded image at index "1.1"}}
-
-test textImage-1.6 {configure argument checking} {
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image configure } msg] $msg
-} {1 {wrong # args: should be ".t image configure index ?-option value ...?"}}
-
-test textImage-1.7 {configure argument checking} {
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image configure blurf } msg] $msg
-} {1 {bad text index "blurf"}}
-
-test textImage-1.8 {configure argument checking} {
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image configure 1.1 } msg] $msg
-} {1 {no embedded image at index "1.1"}}
-
-test textImage-1.9 {create argument checking} {
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image create} msg] $msg
-} {1 {wrong # args: should be ".t image create index ?-option value ...?"}}
-
-test textImage-1.10 {create argument checking} {
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image create blurf } msg] $msg
-} {1 {bad text index "blurf"}}
-
-test textImage-1.11 {basic argument checking} {
- catch {
- image create photo small -width 5 -height 5
- small put red -to 0 0 4 4
- }
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image create 1000.1000 -image small} msg] $msg
-} {0 small}
-
-test textImage-1.12 {names argument checking} {
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image names dates places} msg] $msg
-} {1 {wrong # args: should be ".t image names"}}
-
-
-test textImage-1.13 {names argument checking} {
- catch {
- image create photo small -width 5 -height 5
- small put red -to 0 0 4 4
- }
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- set result ""
- lappend result [.t image names]
- .t image create insert -image small
- lappend result [.t image names]
- .t image create insert -image small
- lappend result [.t image names]
- .t image create insert -image small -name little
- lappend result [.t image names]
-} {{} small {small#1 small} {small#1 small little}}
-
-test textImage-1.14 {basic argument checking} {
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image huh} msg] $msg
-} {1 {bad option "huh": must be cget, configure, create, or names}}
-
-test textImage-1.15 {align argument checking} {
- catch {
- image create photo small -width 5 -height 5
- small put red -to 0 0 4 4
- }
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- list [catch {.t image create end -image small -align wrong} msg] $msg
-} {1 {bad align "wrong": must be baseline, bottom, center, or top}}
-
-test textImage-1.16 {configure} {
- catch {
- image create photo small -width 5 -height 5
- small put red -to 0 0 4 4
- }
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- .t image create end -image small
- .t image configure small
-} {{-align {} {} center center} {-padx {} {} 0 0} {-pady {} {} 0 0} {-image {} {} {} small} {-name {} {} {} {}}}
-
-test textImage-1.17 {basic cget options} {
- catch {
- image create photo small -width 5 -height 5
- small put red -to 0 0 4 4
- }
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- .t image create end -image small
- set result ""
- foreach i {align padx pady image name} {
- lappend result $i:[.t image cget small -$i]
- }
- set result
-} {align:center padx:0 pady:0 image:small name:}
-
-test textImage-1.18 {basic configure options} {
- catch {
- image create photo small -width 5 -height 5
- small put red -to 0 0 4 4
- image create photo large -width 50 -height 50
- large put green -to 0 0 50 50
- }
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- .t image create end -image small
- set result ""
- foreach {option value} {align top padx 5 pady 7 image large name none} {
- .t image configure small -$option $value
- }
- update
- .t image configure small
-} {{-align {} {} center top} {-padx {} {} 0 5} {-pady {} {} 0 7} {-image {} {} {} large} {-name {} {} {} none}}
-
-test textImage-1.19 {basic image naming} {
- catch {
- image create photo small -width 5 -height 5
- small put red -to 0 0 4 4
- }
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- .t image create end -image small
- .t image create end -image small -name small
- .t image create end -image small -name small#6342
- .t image create end -image small -name small
- lsort [.t image names]
-} {small small#1 small#6342 small#6343}
-
-test textImage-2.1 {debug} {
- catch {
- image create photo small -width 5 -height 5
- small put red -to 0 0 4 4
- }
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- .t debug 1
- .t insert end front
- .t image create end -image small
- .t insert end back
- .t delete small
- .t image names
- .t debug 0
-} {}
-
-test textImage-3.1 {image change propagation} {
- catch {
- image create photo vary -width 5 -height 5
- small put red -to 0 0 4 4
- }
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- .t image create end -image vary -align top
- update
- set result ""
- lappend result base:[.t bbox vary]
- foreach i {10 20 40} {
- vary configure -width $i -height $i
- update
- lappend result $i:[.t bbox vary]
- }
- set result
-} {{base:0 0 5 5} {10:0 0 10 10} {20:0 0 20 20} {40:0 0 40 40}}
-
-test textImage-3.2 {delayed image management} {
- catch {
- image create photo small -width 5 -height 5
- small put red -to 0 0 4 4
- }
- catch {destroy .t}
- text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
- pack .t
- .t image create end -name test
- update
- set result ""
- lappend result [.t bbox test]
- .t image configure test -image small -align top
- update
- lappend result [.t bbox test]
-} {{} {0 0 5 5}}
+test textImage-1.1 {basic argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {wrong # args: should be ".t image option ?arg ...?"}
+
+test textImage-1.2 {basic argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image c
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {ambiguous option "c": must be cget, configure, create, or names}
+
+test textImage-1.3 {cget argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image cget
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {wrong # args: should be ".t image cget index option"}
+
+test textImage-1.4 {cget argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image cget blurf -flurp
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {bad text index "blurf"}
+
+test textImage-1.5 {cget argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image cget 1.1 -flurp
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {no embedded image at index "1.1"}
+
+test textImage-1.6 {configure argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image configure
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {wrong # args: should be ".t image configure index ?-option value ...?"}
+
+test textImage-1.7 {configure argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image configure blurf
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {bad text index "blurf"}
+
+test textImage-1.8 {configure argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image configure 1.1
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {no embedded image at index "1.1"}
+
+test textImage-1.9 {create argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {wrong # args: should be ".t image create index ?-option value ...?"}
+
+test textImage-1.10 {create argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create blurf
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {bad text index "blurf"}
+
+test textImage-1.11 {basic argument checking} -setup {
+ destroy .t
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create 1000.1000 -image small
+} -cleanup {
+ destroy .t
+ image delete small
+} -returnCodes ok -result {small}
+
+test textImage-1.12 {names argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image names dates places
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {wrong # args: should be ".t image names"}
+
+
+test textImage-1.13 {names argument checking} -setup {
+ destroy .t
+ set result ""
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ lappend result [.t image names]
+ .t image create insert -image small
+ lappend result [.t image names]
+ .t image create insert -image small
+ lappend result [.t image names]
+ .t image create insert -image small -name little
+ lappend result [.t image names]
+} -cleanup {
+ destroy .t
+ image delete small
+} -result {{} small {small#1 small} {small#1 small little}}
+
+test textImage-1.14 {basic argument checking} -setup {
+ destroy .t
+} -body {
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image huh
+} -cleanup {
+ destroy .t
+} -returnCodes error -result {bad option "huh": must be cget, configure, create, or names}
+
+test textImage-1.15 {align argument checking} -setup {
+ destroy .t
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create end -image small -align wrong
+} -cleanup {
+ destroy .t
+ image delete small
+} -returnCodes error -result {bad align "wrong": must be baseline, bottom, center, or top}
+
+test textImage-1.16 {configure} -setup {
+ destroy .t
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create end -image small
+ .t image configure small
+} -cleanup {
+ destroy .t
+ image delete small
+} -result {{-align {} {} center center} {-padx {} {} 0 0} {-pady {} {} 0 0} {-image {} {} {} small} {-name {} {} {} {}}}
+
+test textImage-1.17 {basic cget options} -setup {
+ destroy .t
+ set result ""
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create end -image small
+ foreach i {align padx pady image name} {
+ lappend result $i:[.t image cget small -$i]
+ }
+ return $result
+} -cleanup {
+ destroy .t
+ image delete small
+} -result {align:center padx:0 pady:0 image:small name:}
+
+test textImage-1.18 {basic configure options} -setup {
+ destroy .t
+ set result ""
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ image create photo large -width 50 -height 50
+ large put green -to 0 0 50 50
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create end -image small
+ foreach {option value} {align top padx 5 pady 7 image large name none} {
+ .t image configure small -$option $value
+ }
+ update
+ .t image configure small
+} -cleanup {
+ destroy .t
+ image delete small large
+} -result {{-align {} {} center top} {-padx {} {} 0 5} {-pady {} {} 0 7} {-image {} {} {} large} {-name {} {} {} none}}
+
+test textImage-1.19 {basic image naming} -setup {
+ destroy .t
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create end -image small
+ .t image create end -image small -name small
+ .t image create end -image small -name small#6342
+ .t image create end -image small -name small
+ lsort [.t image names]
+} -cleanup {
+ destroy .t
+ image delete small
+} -result {small small#1 small#6342 small#6343}
+
+test textImage-2.1 {debug} -setup {
+ destroy .t
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t debug 1
+ .t insert end front
+ .t image create end -image small
+ .t insert end back
+ .t delete small
+ .t image names
+ .t debug 0
+} -cleanup {
+ destroy .t
+ image delete small
+} -result {}
+
+
+test textImage-3.1 {image change propagation} -setup {
+ destroy .t
+ set result ""
+} -body {
+ catch {
+ image create photo vary -width 5 -height 5
+ vary put red -to 0 0 4 4
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create end -image vary -align top
+ update
+ lappend result base:[.t bbox vary]
+ foreach i {10 20 40} {
+ vary configure -width $i -height $i
+ update
+ lappend result $i:[.t bbox vary]
+ }
+ return $result
+} -cleanup {
+ destroy .t
+ image delete vary
+} -result {{base:0 0 5 5} {10:0 0 10 10} {20:0 0 20 20} {40:0 0 40 40}}
+
+# Fails in some environments (both in Linux and winXP)
+test textImage-3.2 {delayed image management} -setup {
+ destroy .t
+ set result ""
+} -body {
+ catch {
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ }
+ text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
+ pack .t
+ .t image create end -name test
+ update
+ lappend result [.t bbox test]
+ .t image configure test -image small -align top
+ update
+ lappend result [.t bbox test]
+} -cleanup {
+ destroy .t
+ image delete small
+} -result {{} {0 0 5 5}}
+
# some temporary random tests
-test textImage-4.1 {alignment checking - except baseline} {
+test textImage-4.1 {alignment checking - except baseline} -setup {
+ destroy .t
+ set result ""
+} -body {
catch {
- image create photo small -width 5 -height 5
- small put red -to 0 0 4 4
- image create photo large -width 50 -height 50
- large put green -to 0 0 50 50
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ image create photo large -width 50 -height 50
+ large put green -to 0 0 50 50
}
- catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image create end -image large
.t image create end -image small
.t insert end test
update
- set result ""
lappend result default:[.t bbox small]
foreach i {top bottom center} {
- .t image configure small -align $i
- update
- lappend result [.t image cget small -align]:[.t bbox small]
+ .t image configure small -align $i
+ update
+ lappend result [.t image cget small -align]:[.t bbox small]
}
- set result
-} {{default:50 22 5 5} {top:50 0 5 5} {bottom:50 45 5 5} {center:50 22 5 5}}
-
-test textImage-4.2 {alignment checking - baseline} {
+ return $result
+} -cleanup {
+ destroy .t
+ image delete small large
+} -result {{default:50 22 5 5} {top:50 0 5 5} {bottom:50 45 5 5} {center:50 22 5 5}}
+
+test textImage-4.2 {alignment checking - baseline} -setup {
+ destroy .t
+ set result ""
+} -body {
catch {
- image create photo small -width 5 -height 5
- small put red -to 0 0 4 4
- image create photo large -width 50 -height 50
- large put green -to 0 0 50 50
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ image create photo large -width 50 -height 50
+ large put green -to 0 0 50 50
}
- catch {destroy .t}
font create test_font2 -size 5
text .t -font test_font2 -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image create end -image large
.t image create end -image small -align baseline
.t insert end test
- set result ""
# Sizes larger than 25 can be too big and lead to a negative 'norm',
# at least on Windows XP with certain settings.
foreach size {10 15 20 25} {
- font configure test_font2 -size $size
- array set Metrics [font metrics test_font2]
- update
- foreach {x y w h} [.t bbox small] {}
- set norm [expr {
- (([image height large] - $Metrics(-linespace))/2
- + $Metrics(-ascent) - [image height small] - $y)
- }]
- lappend result "$size $norm"
+ font configure test_font2 -size $size
+ array set Metrics [font metrics test_font2]
+ update
+ foreach {x y w h} [.t bbox small] {}
+ set norm [expr {
+ (([image height large] - $Metrics(-linespace))/2
+ + $Metrics(-ascent) - [image height small] - $y)
+ }]
+ lappend result "$size $norm"
}
+ return $result
+} -cleanup {
+ destroy .t
+ image delete small large
font delete test_font2
unset Metrics
- set result
-} {{10 0} {15 0} {20 0} {25 0}}
+} -result {{10 0} {15 0} {20 0} {25 0}}
-test textImage-4.3 {alignment and padding checking} {fonts} {
+test textImage-4.3 {alignment and padding checking} -constraints {
+ fonts
+} -setup {
+ destroy .t
+ set result ""
+} -body {
catch {
- image create photo small -width 5 -height 5
- small put red -to 0 0 4 4
- image create photo large -width 50 -height 50
- large put green -to 0 0 50 50
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ image create photo large -width 50 -height 50
+ large put green -to 0 0 50 50
}
- catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image create end -image large
.t image create end -image small -padx 5 -pady 10
.t insert end test
update
- set result ""
lappend result default:[.t bbox small]
foreach i {top bottom center baseline} {
- .t image configure small -align $i
- update
- lappend result $i:[.t bbox small]
+ .t image configure small -align $i
+ update
+ lappend result $i:[.t bbox small]
}
- set result
-} {{default:55 22 5 5} {top:55 10 5 5} {bottom:55 35 5 5} {center:55 22 5 5} {baseline:55 22 5 5}}
+ return $result
+} -cleanup {
+ destroy .t
+ image delete small large
+} -result {{default:55 22 5 5} {top:55 10 5 5} {bottom:55 35 5 5} {center:55 22 5 5} {baseline:55 22 5 5}}
-test textImage-5.0 {peer widget images} {
+
+test textImage-5.1 {peer widget images} -setup {
+ destroy .t .tt
+} -body {
catch {
- image create photo small -width 5 -height 5
- small put red -to 0 0 4 4
- image create photo large -width 50 -height 50
- large put green -to 0 0 50 50
+ image create photo small -width 5 -height 5
+ small put red -to 0 0 4 4
+ image create photo large -width 50 -height 50
+ large put green -to 0 0 50 50
}
- catch {destroy .t .tt}
pack [text .t]
toplevel .tt
pack [.t peer create .tt.t]
@@ -360,13 +455,18 @@ test textImage-5.0 {peer widget images} {
.t insert end test
update
destroy .t .tt
-} {}
+} -cleanup {
+ image delete small large
+} -result {}
# cleanup
-catch {destroy .t}
+destroy .t
foreach image [image names] {image delete $image}
font delete test_font
# cleanup
cleanupTests
return
+
+
+
diff --git a/tests/textMark.test b/tests/textMark.test
index d08b037..2942cba 100644
--- a/tests/textMark.test
+++ b/tests/textMark.test
@@ -6,22 +6,34 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: textMark.test,v 1.10 2008/07/23 23:24:24 nijtmans Exp $
+# RCS: @(#) $Id: textMark.test,v 1.11 2008/08/28 08:52:06 aniap Exp $
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
-catch {destroy .t}
+
+destroy .t
text .t -width 20 -height 10
-testConstraint haveCourier12 [expr {[catch {
- .t configure -font {Courier 12}
-}] == 0}]
pack append . .t {top expand fill}
update
.t debug on
wm geometry . {}
+entry .t.e
+
+.t insert 1.0 "Line 1
+abcdefghijklm
+12345
+Line 4
+bOy GIrl .#@? x_yz
+!@#$%
+Line 7"
+testConstraint haveCourier12 [expr {[catch {
+ .t configure -font {Courier 12}
+}] == 0}]
+
# 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.
@@ -30,195 +42,298 @@ wm minsize . 1 1
wm positionfrom . user
wm deiconify .
-entry .t.e
-.t insert 1.0 "Line 1
-abcdefghijklm
-12345
-Line 4
-bOy GIrl .#@? x_yz
-!@#$%
-Line 7"
-test textMark-1.1 {TkTextMarkCmd - missing option} haveCourier12 {
- list [catch {.t mark} msg] $msg
-} {1 {wrong # args: should be ".t mark option ?arg ...?"}}
-test textMark-1.2 {TkTextMarkCmd - bogus option} haveCourier12 {
- list [catch {.t mark gorp} msg] $msg
-} {1 {bad mark option "gorp": must be gravity, names, next, previous, set, or unset}}
-test textMark-1.3 {TkTextMarkCmd - "gravity" option} haveCourier12 {
- list [catch {.t mark gravity foo} msg] $msg
-} {1 {there is no mark named "foo"}}
-test textMark-1.4 {TkTextMarkCmd - "gravity" option} haveCourier12 {
- .t mark unset x
+test textMark-1.1 {TkTextMarkCmd - missing option} -constraints {
+ haveCourier12
+} -body {
+ .t mark
+} -returnCodes error -result {wrong # args: should be ".t mark option ?arg ...?"}
+test textMark-1.2 {TkTextMarkCmd - bogus option} -constraints {
+ haveCourier12
+} -body {
+ .t mark gorp
+} -returnCodes error -result {bad mark option "gorp": must be gravity, names, next, previous, set, or unset}
+test textMark-1.3 {TkTextMarkCmd - "gravity" option} -constraints {
+ haveCourier12
+} -body {
+ .t mark gravity foo
+} -returnCodes error -result {there is no mark named "foo"}
+test textMark-1.4 {TkTextMarkCmd - "gravity" option} -constraints {
+ haveCourier12
+} -body {
.t mark set x 1.3
.t insert 1.3 x
list [.t mark gravity x] [.t index x]
-} {right 1.4}
-test textMark-1.5 {TkTextMarkCmd - "gravity" option} haveCourier12 {
- .t mark unset x
+} -result {right 1.4}
+test textMark-1.5 {TkTextMarkCmd - "gravity" option} -constraints {
+ haveCourier12
+} -body {
.t mark set x 1.3
.t mark g x left
.t insert 1.3 x
list [.t mark gravity x] [.t index x]
-} {left 1.3}
-test textMark-1.6 {TkTextMarkCmd - "gravity" option} haveCourier12 {
- .t mark unset x
+} -result {left 1.3}
+test textMark-1.6 {TkTextMarkCmd - "gravity" option} -constraints {
+ haveCourier12
+} -body {
.t mark set x 1.3
.t mark gravity x right
.t insert 1.3 x
list [.t mark gravity x] [.t index x]
-} {right 1.4}
-test textMark-1.7 {TkTextMarkCmd - "gravity" option} haveCourier12 {
- list [catch {.t mark gravity x gorp} msg] $msg
-} {1 {bad mark gravity "gorp": must be left or right}}
-test textMark-1.8 {TkTextMarkCmd - "gravity" option} haveCourier12 {
- list [catch {.t mark gravity} msg] $msg
-} {1 {wrong # args: should be ".t mark gravity markName ?gravity?"}}
-
-test textMark-2.1 {TkTextMarkCmd - "names" option} haveCourier12 {
- list [catch {.t mark names 2} msg] $msg
-} {1 {wrong # args: should be ".t mark names"}}
-.t mark unset x
-test textMark-2.2 {TkTextMarkCmd - "names" option} haveCourier12 {
+} -result {right 1.4}
+test textMark-1.7 {TkTextMarkCmd - "gravity" option} -constraints {
+ haveCourier12
+} -body {
+ .t mark set x 1.3
+ .t mark gravity x gorp
+} -returnCodes error -result {bad mark gravity "gorp": must be left or right}
+test textMark-1.8 {TkTextMarkCmd - "gravity" option} -constraints {
+ haveCourier12
+} -body {
+ .t mark gravity
+} -returnCodes error -result {wrong # args: should be ".t mark gravity markName ?gravity?"}
+
+
+test textMark-2.1 {TkTextMarkCmd - "names" option} -constraints {
+ haveCourier12
+} -body {
+ .t mark names 2
+} -returnCodes error -result {wrong # args: should be ".t mark names"}
+test textMark-2.2 {TkTextMarkCmd - "names" option} -constraints {
+ haveCourier12
+} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
lsort [.t mark na]
-} {current insert}
-test textMark-2.3 {TkTextMarkCmd - "names" option} haveCourier12 {
+} -result {current insert}
+test textMark-2.3 {TkTextMarkCmd - "names" option} -constraints {
+ haveCourier12
+} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
.t mark set a 1.1
.t mark set "b c" 2.3
lsort [.t mark names]
-} {a {b c} current insert}
-
-test textMark-3.1 {TkTextMarkCmd - "set" option} haveCourier12 {
- list [catch {.t mark set a} msg] $msg
-} {1 {wrong # args: should be ".t mark set markName index"}}
-test textMark-3.2 {TkTextMarkCmd - "set" option} haveCourier12 {
- list [catch {.t mark s a b c} msg] $msg
-} {1 {wrong # args: should be ".t mark set markName index"}}
-test textMark-3.3 {TkTextMarkCmd - "set" option} haveCourier12 {
- list [catch {.t mark set a @x} msg] $msg
-} {1 {bad text index "@x"}}
-test textMark-3.4 {TkTextMarkCmd - "set" option} haveCourier12 {
+} -result {a {b c} current insert}
+
+
+test textMark-3.1 {TkTextMarkCmd - "set" option} -constraints {
+ haveCourier12
+} -body {
+ .t mark set a
+} -returnCodes error -result {wrong # args: should be ".t mark set markName index"}
+test textMark-3.2 {TkTextMarkCmd - "set" option} -constraints {
+ haveCourier12
+} -body {
+ .t mark s a b c
+} -returnCodes error -result {wrong # args: should be ".t mark set markName index"}
+test textMark-3.3 {TkTextMarkCmd - "set" option} -constraints {
+ haveCourier12
+} -body {
+ .t mark set a @x
+} -returnCodes error -result {bad text index "@x"}
+test textMark-3.4 {TkTextMarkCmd - "set" option} -constraints {
+ haveCourier12
+} -body {
.t mark set a 1.2
.t index a
-} 1.2
-test textMark-3.5 {TkTextMarkCmd - "set" option} haveCourier12 {
+} -result 1.2
+test textMark-3.5 {TkTextMarkCmd - "set" option} -constraints {
+ haveCourier12
+} -body {
.t mark set a end
.t index a
-} {8.0}
+} -result {8.0}
-test textMark-4.1 {TkTextMarkCmd - "unset" option} haveCourier12 {
- list [catch {.t mark unset} msg] $msg
-} {0 {}}
-test textMark-4.2 {TkTextMarkCmd - "unset" option} haveCourier12 {
+
+test textMark-4.1 {TkTextMarkCmd - "unset" option} -constraints {
+ haveCourier12
+} -body {
+ .t mark unset
+} -returnCodes ok -result {}
+test textMark-4.2 {TkTextMarkCmd - "unset" option} -constraints {
+ haveCourier12
+} -body {
.t mark set a 1.2
.t mark set b 2.3
.t mark unset a b
- list [catch {.t index a} msg] $msg [catch {.t index b} msg2] $msg2
-} {1 {bad text index "a"} 1 {bad text index "b"}}
-test textMark-4.3 {TkTextMarkCmd - "unset" option} haveCourier12 {
+ .t index a
+} -returnCodes error -result {bad text index "a"}
+test textMark-4.2 {TkTextMarkCmd - "unset" option} -constraints {
+ haveCourier12
+} -body {
+ .t mark set a 1.2
+ .t mark set b 2.3
+ .t mark unset a b
+ .t index b
+} -returnCodes error -result {bad text index "b"}
+test textMark-4.3 {TkTextMarkCmd - "unset" option} -constraints {
+ haveCourier12
+} -body {
.t mark set a 1.2
.t mark set b 2.3
.t mark set 49ers 3.1
eval .t mark unset [.t mark names]
lsort [.t mark names]
-} {current insert}
+} -result {current insert}
+
+
+test textMark-5.1 {TkTextMarkCmd - miscellaneous} -constraints {
+ haveCourier12
+} -body {
+ .t mark
+} -returnCodes error -result {wrong # args: should be ".t mark option ?arg ...?"}
+test textMark-5.2 {TkTextMarkCmd - miscellaneous} -constraints {
+ haveCourier12
+} -body {
+ .t mark foo
+} -returnCodes error -result {bad mark option "foo": must be gravity, names, next, previous, set, or unset}
-test textMark-5.1 {TkTextMarkCmd - miscellaneous} haveCourier12 {
- list [catch {.t mark} msg] $msg
-} {1 {wrong # args: should be ".t mark option ?arg ...?"}}
-test textMark-5.2 {TkTextMarkCmd - miscellaneous} haveCourier12 {
- list [catch {.t mark foo} msg] $msg
-} {1 {bad mark option "foo": must be gravity, names, next, previous, set, or unset}}
-test textMark-6.1 {TkTextMarkSegToIndex} haveCourier12 {
+test textMark-6.1 {TkTextMarkSegToIndex} -constraints haveCourier12 -body {
.t mark set a 1.2
.t mark set b 1.2
.t mark set c 1.2
.t mark set d 1.4
list [.t index a] [.t index b] [.t index c ] [.t index d]
-} {1.2 1.2 1.2 1.4}
-
-catch {eval {.t mark unset} [.t mark names]}
-test textMark-7.1 {MarkFindNext - invalid mark name} haveCourier12 {
- catch {.t mark next bogus} x
- set x
-} {bad text index "bogus"}
-test textMark-7.2 {MarkFindNext - marks at same location} haveCourier12 {
+} -result {1.2 1.2 1.2 1.4}
+
+
+test textMark-7.1 {MarkFindNext - invalid mark name} -constraints {
+ haveCourier12
+} -body {
+ .t mark next bogus
+} -returnCodes error -result {bad text index "bogus"}
+test textMark-7.2 {MarkFindNext - marks at same location} -constraints {
+ haveCourier12
+} -body {
.t mark set insert 2.0
.t mark set current 2.0
.t mark next current
-} {insert}
-test textMark-7.3 {MarkFindNext - numerical starting mark} haveCourier12 {
+} -result {insert}
+test textMark-7.3 {MarkFindNext - numerical starting mark} -constraints {
+ haveCourier12
+} -body {
.t mark set current 1.0
.t mark set insert 1.0
.t mark next 1.0
-} {insert}
-test textMark-7.4 {MarkFindNext - mark on the same line} haveCourier12 {
+} -result {insert}
+test textMark-7.4 {MarkFindNext - mark on the same line} -constraints {
+ haveCourier12
+} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
.t mark set current 1.0
.t mark set insert 1.1
.t mark next current
-} {insert}
-test textMark-7.5 {MarkFindNext - mark on the next line} haveCourier12 {
+} -result {insert}
+test textMark-7.5 {MarkFindNext - mark on the next line} -constraints {
+ haveCourier12
+} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
.t mark set current 1.end
.t mark set insert 2.0
.t mark next current
-} {insert}
-test textMark-7.6 {MarkFindNext - mark far away} haveCourier12 {
+} -result {insert}
+test textMark-7.6 {MarkFindNext - mark far away} -constraints {
+ haveCourier12
+} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
.t mark set current 1.2
.t mark set insert 7.0
.t mark next current
-} {insert}
-test textMark-7.7 {MarkFindNext - mark on top of end} haveCourier12 {
+} -result {insert}
+test textMark-7.7 {MarkFindNext - mark on top of end} -constraints {
+ haveCourier12
+} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
.t mark set current end
.t mark next end
-} {current}
-test textMark-7.8 {MarkFindNext - no next mark} haveCourier12 {
+} -result {current}
+test textMark-7.8 {MarkFindNext - no next mark} -constraints {
+ haveCourier12
+} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
.t mark set current 1.0
.t mark set insert 3.0
.t mark next insert
-} {}
-test textMark-8.1 {MarkFindPrev - invalid mark name} haveCourier12 {
- catch {.t mark prev bogus} x
- set x
-} {bad text index "bogus"}
-test textMark-8.2 {MarkFindPrev - marks at same location} haveCourier12 {
+} -result {}
+
+
+test textMark-8.1 {MarkFindPrev - invalid mark name} -constraints {
+ haveCourier12
+} -body {
+ .t mark prev bogus
+} -returnCodes error -result {bad text index "bogus"}
+test textMark-8.2 {MarkFindPrev - marks at same location} -constraints {
+ haveCourier12
+} -body {
.t mark set insert 2.0
.t mark set current 2.0
.t mark prev insert
-} {current}
-test textMark-8.3 {MarkFindPrev - numerical starting mark} haveCourier12 {
+} -result {current}
+test textMark-8.3 {MarkFindPrev - numerical starting mark} -constraints {
+ haveCourier12
+} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
.t mark set current 1.0
.t mark set insert 1.0
.t mark prev 1.1
-} {current}
-test textMark-8.4 {MarkFindPrev - mark on the same line} haveCourier12 {
+} -result {current}
+test textMark-8.4 {MarkFindPrev - mark on the same line} -constraints {
+ haveCourier12
+} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
.t mark set current 1.0
.t mark set insert 1.1
.t mark prev insert
-} {current}
-test textMark-8.5 {MarkFindPrev - mark on the previous line} haveCourier12 {
+} -result {current}
+test textMark-8.5 {MarkFindPrev - mark on the previous line} -constraints {
+ haveCourier12
+} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
.t mark set current 1.end
.t mark set insert 2.0
.t mark prev insert
-} {current}
-test textMark-8.6 {MarkFindPrev - mark far away} haveCourier12 {
+} -result {current}
+test textMark-8.6 {MarkFindPrev - mark far away} -constraints {
+ haveCourier12
+} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
.t mark set current 1.2
.t mark set insert 7.0
.t mark prev insert
-} {current}
-test textMark-8.7 {MarkFindPrev - mark on top of end} haveCourier12 {
+} -result {current}
+test textMark-8.7 {MarkFindPrev - mark on top of end} -constraints {
+ haveCourier12
+} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
.t mark set insert 3.0
.t mark set current end
.t mark prev end
-} {insert}
-test textMark-8.8 {MarkFindPrev - no previous mark} haveCourier12 {
+} -result {insert}
+test textMark-8.8 {MarkFindPrev - no previous mark} -constraints {
+ haveCourier12
+} -setup {
+ .t mark unset {*}[.t mark names]
+} -body {
.t mark set current 1.0
.t mark set insert 3.0
.t mark prev current
-} {}
+} -result {}
-catch {destroy .t}
+destroy .t
# cleanup
cleanupTests
return
+
diff --git a/tests/textTag.test b/tests/textTag.test
index fa950fc..bbda6e4 100644
--- a/tests/textTag.test
+++ b/tests/textTag.test
@@ -6,21 +6,23 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: textTag.test,v 1.13 2008/07/23 23:24:26 nijtmans Exp $
+# RCS: @(#) $Id: textTag.test,v 1.14 2008/08/28 08:52:06 aniap Exp $
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
-namespace import -force tcltest::test
-catch {destroy .t}
+destroy .t
text .t -width 20 -height 10
testConstraint haveCourier12 [expr {[catch {
.t configure -font {Courier 12}
}] == 0}]
+
pack append . .t {top expand fill}
update
.t debug on
+
wm geometry . {}
set bigFont {Helvetica 24}
@@ -32,9 +34,6 @@ wm minsize . 1 1
wm positionfrom . user
wm deiconify .
-entry .t.e
-.t.e insert 0 "Text"
-
.t insert 1.0 "Line 1
abcdefghijklm
12345
@@ -44,539 +43,1289 @@ bOy GIrl .#@? x_yz
Line 7"
-set i 1
-foreach test {
- {-background #012345 #012345 non-existent
- {unknown color name "non-existent"}}
- {-bgstipple gray50 gray50 badStipple
- {bitmap "badStipple" not defined}}
- {-borderwidth 2 2 46q
- {bad screen distance "46q"}}
- {-fgstipple gray25 gray25 bogus
- {bitmap "bogus" not defined}}
- {-font fixed fixed {}
- {font "" doesn't exist}}
- {-foreground #001122 #001122 {silly color}
- {unknown color name "silly color"}}
- {-justify left left middle
- {bad justification "middle": must be left, right, or center}}
- {-lmargin1 10 10 bad
- {bad screen distance "bad"}}
- {-lmargin2 10 10 bad
- {bad screen distance "bad"}}
- {-offset 2 2 100xyz
- {bad screen distance "100xyz"}}
- {-overstrike on on stupid
- {expected boolean value but got "stupid"}}
- {-relief raised raised stupid
- {bad relief type "stupid": must be flat, groove, raised, ridge, solid, or sunken}}
- {-rmargin 10 10 bad
- {bad screen distance "bad"}}
- {-spacing1 10 10 bad
- {bad screen distance "bad"}}
- {-spacing2 10 10 bad
- {bad screen distance "bad"}}
- {-spacing3 10 10 bad
- {bad screen distance "bad"}}
- {-tabs {10 20 30} {10 20 30} {10 fork}
- {bad tab alignment "fork": must be left, right, center, or numeric}}
- {-underline no no stupid
- {expected boolean value but got "stupid"}}
-} {
- set name [lindex $test 0]
- test textTag-1.$i {tag configuration options} haveCourier12 {
- .t tag configure x $name [lindex $test 1]
- .t tag cget x $name
- } [lindex $test 2]
- incr i
- if {[lindex $test 3] != ""} {
- test textTag-1.$i {configuration options} haveCourier12 {
- list [catch {.t tag configure x $name [lindex $test 3]} msg] $msg
- } [list 1 [lindex $test 4]]
- }
- .t tag configure x $name [lindex [.t tag configure x $name] 3]
- incr i
-}
-test textTag-2.1 {TkTextTagCmd - "add" option} haveCourier12 {
- list [catch {.t tag} msg] $msg
-} {1 {wrong # args: should be ".t tag option ?arg ...?"}}
-test textTag-2.2 {TkTextTagCmd - "add" option} haveCourier12 {
- list [catch {.t tag gorp} msg] $msg
-} {1 {bad tag option "gorp": must be add, bind, cget, configure, delete, lower, names, nextrange, prevrange, raise, ranges, or remove}}
-test textTag-2.3 {TkTextTagCmd - "add" option} haveCourier12 {
- list [catch {.t tag add foo} msg] $msg
-} {1 {wrong # args: should be ".t tag add tagName index1 ?index2 index1 index2 ...?"}}
-test textTag-2.4 {TkTextTagCmd - "add" option} haveCourier12 {
- list [catch {.t tag add x gorp} msg] $msg
-} {1 {bad text index "gorp"}}
-test textTag-2.5 {TkTextTagCmd - "add" option} haveCourier12 {
- list [catch {.t tag add x 1.2 gorp} msg] $msg
-} {1 {bad text index "gorp"}}
-test textTag-2.6 {TkTextTagCmd - "add" option} haveCourier12 {
+test textTag-1.1 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -background #012345
+ .t tag cget x -background
+} -cleanup {
+ .t tag configure x -background [lindex [.t tag configure x -background] 3]
+} -result {#012345}
+test textTag-1.2 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -background non-existent
+} -cleanup {
+ .t tag configure x -background [lindex [.t tag configure x -background] 3]
+} -returnCodes error -result {unknown color name "non-existent"}
+test textTag-1.3 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -bgstipple gray50
+ .t tag cget x -bgstipple
+} -cleanup {
+ .t tag configure x -bgstipple [lindex [.t tag configure x -bgstipple] 3]
+} -result {gray50}
+test textTag-1.4 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -bgstipple badStipple
+} -cleanup {
+ .t tag configure x -bgstipple [lindex [.t tag configure x -bgstipple] 3]
+} -returnCodes error -result {bitmap "badStipple" not defined}
+test textTag-1.5 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -borderwidth 2
+ .t tag cget x -borderwidth
+} -cleanup {
+ .t tag configure x -borderwidth [lindex [.t tag configure x -borderwidth] 3]
+} -result {2}
+test textTag-1.6 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -borderwidth 46q
+} -cleanup {
+ .t tag configure x -borderwidth [lindex [.t tag configure x -borderwidth] 3]
+} -returnCodes error -result {bad screen distance "46q"}
+test textTag-1.7 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -fgstipple gray25
+ .t tag cget x -fgstipple
+} -cleanup {
+ .t tag configure x -fgstipple [lindex [.t tag configure x -fgstipple] 3]
+} -result {gray25}
+test textTag-1.8 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -fgstipple bogus
+} -cleanup {
+ .t tag configure x -fgstipple [lindex [.t tag configure x -fgstipple] 3]
+} -returnCodes error -result {bitmap "bogus" not defined}
+test textTag-1.9 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -font fixed
+ .t tag cget x -font
+} -cleanup {
+ .t tag configure x -font [lindex [.t tag configure x -font] 3]
+} -result {fixed}
+test textTag-1.10 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -foreground #001122
+ .t tag cget x -foreground
+} -cleanup {
+ .t tag configure x -foreground [lindex [.t tag configure x -foreground] 3]
+} -result {#001122}
+test textTag-1.11 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -foreground {silly color}
+} -cleanup {
+ .t tag configure x -foreground [lindex [.t tag configure x -foreground] 3]
+} -returnCodes error -result {unknown color name "silly color"}
+test textTag-1.12 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -justify left
+ .t tag cget x -justify
+} -cleanup {
+ .t tag configure x -justify [lindex [.t tag configure x -justify] 3]
+} -result {left}
+test textTag-1.13 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -justify middle
+} -cleanup {
+ .t tag configure x -justify [lindex [.t tag configure x -justify] 3]
+} -returnCodes error -result {bad justification "middle": must be left, right, or center}
+test textTag-1.14 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -lmargin1 10
+ .t tag cget x -lmargin1
+} -cleanup {
+ .t tag configure x -lmargin1 [lindex [.t tag configure x -lmargin1] 3]
+} -result {10}
+test textTag-1.15 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -lmargin1 bad
+} -cleanup {
+ .t tag configure x -lmargin1 [lindex [.t tag configure x -lmargin1] 3]
+} -returnCodes error -result {bad screen distance "bad"}
+test textTag-1.16 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -lmargin2 10
+ .t tag cget x -lmargin2
+} -cleanup {
+ .t tag configure x -lmargin2 [lindex [.t tag configure x -lmargin2] 3]
+} -result {10}
+test textTag-1.17 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -lmargin2 bad
+} -cleanup {
+ .t tag configure x -lmargin2 [lindex [.t tag configure x -lmargin2] 3]
+} -returnCodes error -result {bad screen distance "bad"}
+test textTag-1.18 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -offset 2
+ .t tag cget x -offset
+} -cleanup {
+ .t tag configure x -offset [lindex [.t tag configure x -offset] 3]
+} -result {2}
+test textTag-1.19 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -offset 100xyz
+} -cleanup {
+ .t tag configure x -offset [lindex [.t tag configure x -offset] 3]
+} -returnCodes error -result {bad screen distance "100xyz"}
+test textTag-1.20 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -overstrike on
+ .t tag cget x -overstrike
+} -cleanup {
+ .t tag configure x -overstrike [lindex [.t tag configure x -overstrike] 3]
+} -result {on}
+test textTag-1.21 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -overstrike stupid
+} -cleanup {
+ .t tag configure x -overstrike [lindex [.t tag configure x -overstrike] 3]
+} -returnCodes error -result {expected boolean value but got "stupid"}
+test textTag-1.22 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -relief raised
+ .t tag cget x -relief
+} -cleanup {
+ .t tag configure x -relief [lindex [.t tag configure x -relief] 3]
+} -result {raised}
+test textTag-1.23 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -relief stupid
+} -cleanup {
+ .t tag configure x -relief [lindex [.t tag configure x -relief] 3]
+} -returnCodes error -result {bad relief type "stupid": must be flat, groove, raised, ridge, solid, or sunken}
+test textTag-1.24 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -rmargin 10
+ .t tag cget x -rmargin
+} -cleanup {
+ .t tag configure x -rmargin [lindex [.t tag configure x -rmargin] 3]
+} -result {10}
+test textTag-1.25 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -rmargin bad
+} -cleanup {
+ .t tag configure x -rmargin [lindex [.t tag configure x -rmargin] 3]
+} -returnCodes error -result {bad screen distance "bad"}
+test textTag-1.26 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -spacing1 10
+ .t tag cget x -spacing1
+} -cleanup {
+ .t tag configure x -spacing1 [lindex [.t tag configure x -spacing1] 3]
+} -result {10}
+test textTag-1.27 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -spacing1 bad
+} -cleanup {
+ .t tag configure x -spacing1 [lindex [.t tag configure x -spacing1] 3]
+} -returnCodes error -result {bad screen distance "bad"}
+test textTag-1.28 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -spacing2 10
+ .t tag cget x -spacing2
+} -cleanup {
+ .t tag configure x -spacing2 [lindex [.t tag configure x -spacing2] 3]
+} -result {10}
+test textTag-1.29 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -spacing2 bad
+} -cleanup {
+ .t tag configure x -spacing2 [lindex [.t tag configure x -spacing2] 3]
+} -returnCodes error -result {bad screen distance "bad"}
+test textTag-1.30 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -spacing3 10
+ .t tag cget x -spacing3
+} -cleanup {
+ .t tag configure x -spacing3 [lindex [.t tag configure x -spacing3] 3]
+} -result {10}
+test textTag-1.31 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -spacing3 bad
+} -cleanup {
+ .t tag configure x -spacing3 [lindex [.t tag configure x -spacing3] 3]
+} -returnCodes error -result {bad screen distance "bad"}
+test textTag-1.32 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -tabs {10 20 30}
+ .t tag cget x -tabs
+} -cleanup {
+ .t tag configure x -tabs [lindex [.t tag configure x -tabs] 3]
+} -result {10 20 30}
+test textTag-1.33 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -tabs {10 fork}
+} -cleanup {
+ .t tag configure x -tabs [lindex [.t tag configure x -tabs] 3]
+} -returnCodes error -result {bad tab alignment "fork": must be left, right, center, or numeric}
+test textTag-1.34 {tag configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -underline no
+ .t tag cget x -underline
+} -cleanup {
+ .t tag configure x -underline [lindex [.t tag configure x -underline] 3]
+} -result {no}
+test textTag-1.35 {configuration options} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -underline stupid
+} -cleanup {
+ .t tag configure x -underline [lindex [.t tag configure x -underline] 3]
+} -returnCodes error -result {expected boolean value but got "stupid"}
+
+
+test textTag-2.1 {TkTextTagCmd - "add" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag
+} -returnCodes error -result {wrong # args: should be ".t tag option ?arg ...?"}
+test textTag-2.2 {TkTextTagCmd - "add" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag gorp
+} -returnCodes error -result {bad tag option "gorp": must be add, bind, cget, configure, delete, lower, names, nextrange, prevrange, raise, ranges, or remove}
+test textTag-2.3 {TkTextTagCmd - "add" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag add foo
+} -returnCodes error -result {wrong # args: should be ".t tag add tagName index1 ?index2 index1 index2 ...?"}
+test textTag-2.4 {TkTextTagCmd - "add" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag add x gorp
+} -returnCodes error -result {bad text index "gorp"}
+test textTag-2.5 {TkTextTagCmd - "add" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag add x 1.2 gorp
+} -returnCodes error -result {bad text index "gorp"}
+test textTag-2.6 {TkTextTagCmd - "add" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete sel
+} -body {
.t tag add sel 3.2 3.4
.t tag add sel 3.2 3.0
.t tag ranges sel
-} {3.2 3.4}
-test textTag-2.7 {TkTextTagCmd - "add" option} haveCourier12 {
+} -result {3.2 3.4}
+test textTag-2.7 {TkTextTagCmd - "add" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
.t tag add x 1.0 1.end
.t tag ranges x
-} {1.0 1.6}
-test textTag-2.8 {TkTextTagCmd - "add" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {1.0 1.6}
+test textTag-2.8 {TkTextTagCmd - "add" option} -constraints {
+ haveCourier12
+} -setup {
.t tag remove x 1.0 end
+} -body {
.t tag add x 1.2
.t tag ranges x
-} {1.2 1.3}
-test textTag-2.9 {TkTextTagCmd - "add" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {1.2 1.3}
+test textTag-2.9 {TkTextTagCmd - "add" option} -constraints {
+ haveCourier12
+} -setup {
+ destroy .t.e
+} -body {
+ entry .t.e
+ .t.e insert 0 "Text"
.t.e select from 0
.t.e select to 4
.t tag add sel 3.2 3.4
selection get
-} 34
-test textTag-2.11 {TkTextTagCmd - "add" option} haveCourier12 {
+} -cleanup {
+ destroy .t.e
+} -result 34
+test textTag-2.10 {TkTextTagCmd - "add" option} -constraints {
+ haveCourier12
+} -setup {
+ destroy .t.e
+} -body {
+ entry .t.e
+ .t.e insert 0 "Text"
.t.e select from 0
.t.e select to 4
.t configure -exportselection 0
.t tag add sel 3.2 3.4
selection get
-} Text
-test textTag-2.12 {TkTextTagCmd - "add" option} haveCourier12 {
+} -cleanup {
+ destroy .t.e
+} -result {Text}
+test textTag-2.11 {TkTextTagCmd - "add" option} -constraints {
+ haveCourier12
+} -body {
.t tag remove sel 1.0 end
.t tag add sel 1.1 1.5 2.4 3.1 4.2 4.4
.t tag ranges sel
-} {1.1 1.5 2.4 3.1 4.2 4.4}
-test textTag-2.13 {TkTextTagCmd - "add" option} haveCourier12 {
+} -result {1.1 1.5 2.4 3.1 4.2 4.4}
+test textTag-2.12 {TkTextTagCmd - "add" option} -constraints {
+ haveCourier12
+} -body {
.t tag remove sel 1.0 end
.t tag add sel 1.1 1.5 2.4
.t tag ranges sel
-} {1.1 1.5 2.4 2.5}
-
-catch {.t tag delete x}
-test textTag-3.1 {TkTextTagCmd - "bind" option} haveCourier12 {
- list [catch {.t tag bind} msg] $msg
-} {1 {wrong # args: should be ".t tag bind tagName ?sequence? ?command?"}}
-test textTag-3.2 {TkTextTagCmd - "bind" option} haveCourier12 {
- list [catch {.t tag bind 1 2 3 4} msg] $msg
-} {1 {wrong # args: should be ".t tag bind tagName ?sequence? ?command?"}}
-test textTag-3.3 {TkTextTagCmd - "bind" option} haveCourier12 {
+} -cleanup {
+ .t tag remove sel 1.0 end
+} -result {1.1 1.5 2.4 2.5}
+
+
+test textTag-3.1 {TkTextTagCmd - "bind" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag bind
+} -returnCodes error -result {wrong # args: should be ".t tag bind tagName ?sequence? ?command?"}
+test textTag-3.2 {TkTextTagCmd - "bind" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag bind 1 2 3 4
+} -returnCodes error -result {wrong # args: should be ".t tag bind tagName ?sequence? ?command?"}
+test textTag-3.3 {TkTextTagCmd - "bind" option} -constraints {
+ haveCourier12
+} -body {
.t tag bind x <Enter> script1
.t tag bind x <Enter>
-} script1
-test textTag-3.4 {TkTextTagCmd - "bind" option} haveCourier12 {
- list [catch {.t tag bind x <Gorp> script2} msg] $msg
-} {1 {bad event type or keysym "Gorp"}}
-test textTag-3.5 {TkTextTagCmd - "bind" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {script1}
+test textTag-3.4 {TkTextTagCmd - "bind" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag bind x <Gorp> script2
+} -returnCodes error -result {bad event type or keysym "Gorp"}
+test textTag-3.5 {TkTextTagCmd - "bind" option} -constraints {
+ haveCourier12
+} -body {
.t tag delete x
.t tag bind x <Enter> script1
- list [catch {.t tag bind x <FocusIn> script2} msg] $msg [.t tag bind x]
-} {1 {requested illegal events; only key, button, motion, enter, leave, and virtual events may be used} <Enter>}
-test textTag-3.6 {TkTextTagCmd - "bind" option} haveCourier12 {
+ .t tag bind x <FocusIn> script2
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {requested illegal events; only key, button, motion, enter, leave, and virtual events may be used}
+test textTag-3.6 {TkTextTagCmd - "bind" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag bind x <Enter> script1
+ catch {.t tag bind x <FocusIn> script2}
+ .t tag bind x
+} -cleanup {
+ .t tag delete x
+} -result {<Enter>}
+test textTag-3.7 {TkTextTagCmd - "bind" option} -constraints {
+ haveCourier12
+} -body {
.t tag delete x
.t tag bind x <Enter> script1
.t tag bind x <Leave> script2
.t tag bind x a xyzzy
list [lsort [.t tag bind x]] [.t tag bind x <Enter>] [.t tag bind x a]
-} {{<Enter> <Leave> a} script1 xyzzy}
-test textTag-3.7 {TkTextTagCmd - "bind" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {{<Enter> <Leave> a} script1 xyzzy}
+test textTag-3.8 {TkTextTagCmd - "bind" option} -constraints {
+ haveCourier12
+} -body {
.t tag delete x
.t tag bind x <Enter> script1
.t tag bind x <Enter> +script2
.t tag bind x <Enter>
-} {script1
+} -cleanup {
+ .t tag delete x
+} -result {script1
script2}
-test textTag-3.7a {TkTextTagCmd - "bind" option} haveCourier12 {
- .t tag delete x
- list [catch {.t tag bind x <Enter>} msg] $msg
-} {0 {}}
-test textTag-3.8 {TkTextTagCmd - "bind" option} haveCourier12 {
- .t tag delete x
- list [catch {.t tag bind x <} msg] $msg
-} {1 {no event type or button # or keysym}}
-
-test textTag-4.1 {TkTextTagCmd - "cget" option} haveCourier12 {
- list [catch {.t tag cget a} msg] $msg
-} {1 {wrong # args: should be ".t tag cget tagName option"}}
-test textTag-4.2 {TkTextTagCmd - "cget" option} haveCourier12 {
- list [catch {.t tag cget a b c} msg] $msg
-} {1 {wrong # args: should be ".t tag cget tagName option"}}
-test textTag-4.3 {TkTextTagCmd - "cget" option} haveCourier12 {
+test textTag-3.9 {TkTextTagCmd - "bind" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag bind x <Enter>
+} -cleanup {
+ .t tag delete x
+} -returnCodes ok -result {}
+test textTag-3.10 {TkTextTagCmd - "bind" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag bind x <
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {no event type or button # or keysym}
+
+
+test textTag-4.1 {TkTextTagCmd - "cget" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag cget a
+} -returnCodes error -result {wrong # args: should be ".t tag cget tagName option"}
+test textTag-4.2 {TkTextTagCmd - "cget" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag cget a b c
+} -returnCodes error -result {wrong # args: should be ".t tag cget tagName option"}
+test textTag-4.3 {TkTextTagCmd - "cget" option} -constraints {
+ haveCourier12
+} -body {
.t tag delete foo
- list [catch {.t tag cget foo bar} msg] $msg
-} {1 {tag "foo" isn't defined in text widget}}
-test textTag-4.4 {TkTextTagCmd - "cget" option} haveCourier12 {
- list [catch {.t tag cget sel bogus} msg] $msg
-} {1 {unknown option "bogus"}}
-test textTag-4.5 {TkTextTagCmd - "cget" option} haveCourier12 {
+ .t tag cget foo bar
+} -returnCodes error -result {tag "foo" isn't defined in text widget}
+test textTag-4.4 {TkTextTagCmd - "cget" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag cget sel bogus
+} -returnCodes error -result {unknown option "bogus"}
+test textTag-4.5 {TkTextTagCmd - "cget" option} -constraints {
+ haveCourier12
+} -body {
.t tag delete x
.t tag configure x -background red
- list [catch {.t tag cget x -background} msg] $msg
-} {0 red}
-
-test textTag-5.1 {TkTextTagCmd - "configure" option} haveCourier12 {
- list [catch {.t tag configure} msg] $msg
-} {1 {wrong # args: should be ".t tag configure tagName ?-option? ?value? ?-option value ...?"}}
-test textTag-5.2 {TkTextTagCmd - "configure" option} haveCourier12 {
- list [catch {.t tag configure x -foo} msg] $msg
-} {1 {unknown option "-foo"}}
-test textTag-5.3 {TkTextTagCmd - "configure" option} haveCourier12 {
- list [catch {.t tag configure x -background red -underline} msg] $msg
-} {1 {value for "-underline" missing}}
-test textTag-5.4 {TkTextTagCmd - "configure" option} haveCourier12 {
+ .t tag cget x -background
+} -cleanup {
+ .t tag delete x
+} -result {red}
+
+
+test textTag-5.1 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure
+} -returnCodes error -result {wrong # args: should be ".t tag configure tagName ?-option? ?value? ?-option value ...?"}
+test textTag-5.2 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -foo
+} -returnCodes error -result {unknown option "-foo"}
+test textTag-5.3 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -background red -underline
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {value for "-underline" missing}
+test textTag-5.4 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
.t tag delete x
.t tag configure x -underline yes
.t tag configure x -underline
-} {-underline {} {} {} yes}
-test textTag-5.5 {TkTextTagCmd - "configure" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {-underline {} {} {} yes}
+test textTag-5.5 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
.t tag delete x
.t tag configure x -overstrike on
.t tag cget x -overstrike
-} {on}
-test textTag-5.6 {TkTextTagCmd - "configure" option} haveCourier12 {
- list [catch {.t tag configure x -overstrike foo} msg] $msg
-} {1 {expected boolean value but got "foo"}}
-test textTag-5.7 {TkTextTagCmd - "configure" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {on}
+test textTag-5.6 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag configure x -overstrike foo
+} -cleanup {
.t tag delete x
- list [catch {.t tag configure x -underline stupid} msg] $msg
-} {1 {expected boolean value but got "stupid"}}
-test textTag-5.8 {TkTextTagCmd - "configure" option} haveCourier12 {
+} -returnCodes error -result {expected boolean value but got "foo"}
+test textTag-5.7 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -underline stupid
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {expected boolean value but got "stupid"}
+test textTag-5.8 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
.t tag delete x
.t tag configure x -justify left
.t tag configure x -justify
-} {-justify {} {} {} left}
-test textTag-5.9 {TkTextTagCmd - "configure" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {-justify {} {} {} left}
+test textTag-5.9 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -justify bogus
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {bad justification "bogus": must be left, right, or center}
+test textTag-5.10 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
.t tag delete x
- list [catch {.t tag configure x -justify bogus} msg] $msg
-} {1 {bad justification "bogus": must be left, right, or center}}
-test textTag-5.10 {TkTextTagCmd - "configure" option} haveCourier12 {
+ .t tag configure x -justify fill
+} -cleanup {
.t tag delete x
- list [catch {.t tag configure x -justify fill} msg] $msg
-} {1 {bad justification "fill": must be left, right, or center}}
-test textTag-5.11 {TkTextTagCmd - "configure" option} haveCourier12 {
+} -returnCodes error -result {bad justification "fill": must be left, right, or center}
+test textTag-5.11 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
.t tag delete x
.t tag configure x -offset 2
.t tag configure x -offset
-} {-offset {} {} {} 2}
-test textTag-5.12 {TkTextTagCmd - "configure" option} haveCourier12 {
+} -cleanup {
.t tag delete x
- list [catch {.t tag configure x -offset 1.0q} msg] $msg
-} {1 {bad screen distance "1.0q"}}
-test textTag-5.13 {TkTextTagCmd - "configure" option} haveCourier12 {
+} -result {-offset {} {} {} 2}
+test textTag-5.12 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -offset 1.0q
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {bad screen distance "1.0q"}
+test textTag-5.13 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
.t tag delete x
.t tag configure x -lmargin1 2 -lmargin2 4 -rmargin 5
list [.t tag configure x -lmargin1] [.t tag configure x -lmargin2] \
- [.t tag configure x -rmargin]
-} {{-lmargin1 {} {} {} 2} {-lmargin2 {} {} {} 4} {-rmargin {} {} {} 5}}
-test textTag-5.14 {TkTextTagCmd - "configure" option} haveCourier12 {
+ [.t tag configure x -rmargin]
+} -cleanup {
+ .t tag delete x
+} -result {{-lmargin1 {} {} {} 2} {-lmargin2 {} {} {} 4} {-rmargin {} {} {} 5}}
+test textTag-5.14 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -lmargin1 2.0x
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {bad screen distance "2.0x"}
+test textTag-5.15 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -lmargin2 gorp
+} -cleanup {
.t tag delete x
- list [catch {.t tag configure x -lmargin1 2.0x} msg] $msg
-} {1 {bad screen distance "2.0x"}}
-test textTag-5.15 {TkTextTagCmd - "configure" option} haveCourier12 {
+} -returnCodes error -result {bad screen distance "gorp"}
+test textTag-5.16 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
.t tag delete x
- list [catch {.t tag configure x -lmargin2 gorp} msg] $msg
-} {1 {bad screen distance "gorp"}}
-test textTag-5.16 {TkTextTagCmd - "configure" option} haveCourier12 {
+ .t tag configure x -rmargin 140.1.1
+} -cleanup {
.t tag delete x
- list [catch {.t tag configure x -rmargin 140.1.1} msg] $msg
-} {1 {bad screen distance "140.1.1"}}
+} -returnCodes error -result {bad screen distance "140.1.1"}
.t tag delete x
-test textTag-5.17 {TkTextTagCmd - "configure" option} haveCourier12 {
+test textTag-5.17 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
.t tag delete x
.t tag configure x -spacing1 2 -spacing2 4 -spacing3 6
list [.t tag configure x -spacing1] [.t tag configure x -spacing2] \
- [.t tag configure x -spacing3]
-} {{-spacing1 {} {} {} 2} {-spacing2 {} {} {} 4} {-spacing3 {} {} {} 6}}
-test textTag-5.18 {TkTextTagCmd - "configure" option} haveCourier12 {
+ [.t tag configure x -spacing3]
+} -cleanup {
.t tag delete x
- list [catch {.t tag configure x -spacing1 2.0x} msg] $msg
-} {1 {bad screen distance "2.0x"}}
-test textTag-5.19 {TkTextTagCmd - "configure" option} haveCourier12 {
+} -result {{-spacing1 {} {} {} 2} {-spacing2 {} {} {} 4} {-spacing3 {} {} {} 6}}
+test textTag-5.18 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
.t tag delete x
- list [catch {.t tag configure x -spacing1 lousy} msg] $msg
-} {1 {bad screen distance "lousy"}}
-test textTag-5.20 {TkTextTagCmd - "configure" option} haveCourier12 {
+ .t tag configure x -spacing1 2.0x
+} -cleanup {
.t tag delete x
- list [catch {.t tag configure x -spacing1 4.2.3} msg] $msg
-} {1 {bad screen distance "4.2.3"}}
-test textTag-5.21 {TkTextTagCmd - "configure" option} haveCourier12 {
+} -returnCodes error -result {bad screen distance "2.0x"}
+test textTag-5.19 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -spacing1 lousy
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {bad screen distance "lousy"}
+test textTag-5.20 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete x
+ .t tag configure x -spacing1 4.2.3
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {bad screen distance "4.2.3"}
+test textTag-5.21 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
.t configure -selectborderwidth 2 -selectforeground blue \
- -selectbackground black
+ -selectbackground black
.t tag configure sel -borderwidth 4 -foreground green -background yellow
set x {}
foreach i {-selectborderwidth -selectforeground -selectbackground} {
- lappend x [lindex [.t configure $i] 4]
+ lappend x [lindex [.t configure $i] 4]
}
- set x
-} {4 green yellow}
-test textTag-5.22 {TkTextTagCmd - "configure" option} haveCourier12 {
+ return $x
+} -result {4 green yellow}
+test textTag-5.22 {TkTextTagCmd - "configure" option} -constraints {
+ haveCourier12
+} -body {
.t configure -selectborderwidth 20
.t tag configure sel -borderwidth {}
.t cget -selectborderwidth
-} {}
+} -result {}
-test textTag-6.1 {TkTextTagCmd - "delete" option} haveCourier12 {
- list [catch {.t tag delete} msg] $msg
-} {1 {wrong # args: should be ".t tag delete tagName ?tagName ...?"}}
-test textTag-6.2 {TkTextTagCmd - "delete" option} haveCourier12 {
- list [catch {.t tag delete zork} msg] $msg
-} {0 {}}
-test textTag-6.3 {TkTextTagCmd - "delete" option} haveCourier12 {
- .t tag delete x
+
+test textTag-6.1 {TkTextTagCmd - "delete" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete
+} -returnCodes error -result {wrong # args: should be ".t tag delete tagName ?tagName ...?"}
+test textTag-6.2 {TkTextTagCmd - "delete" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag delete zork
+} -returnCodes ok -result {}
+test textTag-6.3 {TkTextTagCmd - "delete" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete {*}[.t tag names]
+} -body {
.t tag config x -background black
.t tag config y -foreground white
.t tag config z -background black
.t tag delete y z
lsort [.t tag names]
-} {sel x}
-test textTag-6.4 {TkTextTagCmd - "delete" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {sel x}
+test textTag-6.4 {TkTextTagCmd - "delete" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete {*}[.t tag names]
+} -body {
.t tag config x -background black
.t tag config y -foreground white
.t tag config z -background black
eval .t tag delete [.t tag names]
.t tag names
-} {sel}
-test textTag-6.5 {TkTextTagCmd - "delete" option} haveCourier12 {
+} -result {sel}
+test textTag-6.5 {TkTextTagCmd - "delete" option} -constraints {
+ haveCourier12
+} -body {
.t tag bind x <Enter> foo
.t tag delete x
.t tag configure x -background black
.t tag bind x
-} {}
+} -cleanup {
+ .t tag delete x
+} -result {}
-proc tagsetup {} {
- .t tag delete x y z a b c d
+
+test textTag-7.1 {TkTextTagCmd - "lower" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag lower
+} -returnCodes error -result {wrong # args: should be ".t tag lower tagName ?belowThis?"}
+test textTag-7.2 {TkTextTagCmd - "lower" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag lower foo
+} -returnCodes error -result {tag "foo" isn't defined in text widget}
+test textTag-7.3 {TkTextTagCmd - "lower" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag lower sel bar
+} -returnCodes error -result {tag "bar" isn't defined in text widget}
+test textTag-7.4 {TkTextTagCmd - "lower" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete {*}[.t tag names]
.t tag remove sel 1.0 end
foreach i {a b c d} {
- .t tag configure $i -background black
+ .t tag configure $i -background black
}
-}
-test textTag-7.1 {TkTextTagCmd - "lower" option} haveCourier12 {
- list [catch {.t tag lower} msg] $msg
-} {1 {wrong # args: should be ".t tag lower tagName ?belowThis?"}}
-test textTag-7.2 {TkTextTagCmd - "lower" option} haveCourier12 {
- list [catch {.t tag lower foo} msg] $msg
-} {1 {tag "foo" isn't defined in text widget}}
-test textTag-7.3 {TkTextTagCmd - "lower" option} haveCourier12 {
- list [catch {.t tag lower sel bar} msg] $msg
-} {1 {tag "bar" isn't defined in text widget}}
-test textTag-7.4 {TkTextTagCmd - "lower" option} haveCourier12 {
- tagsetup
+} -body {
.t tag lower c
.t tag names
-} {c sel a b d}
-test textTag-7.5 {TkTextTagCmd - "lower" option} haveCourier12 {
- tagsetup
+} -cleanup {
+ .t tag delete {*}[.t tag names]
+} -result {c sel a b d}
+test textTag-7.5 {TkTextTagCmd - "lower" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete {*}[.t tag names]
+ .t tag remove sel 1.0 end
+ foreach i {a b c d} {
+ .t tag configure $i -background black
+ }
+} -body {
.t tag lower d b
.t tag names
-} {sel a d b c}
-test textTag-7.6 {TkTextTagCmd - "lower" option} haveCourier12 {
- tagsetup
+} -cleanup {
+ .t tag delete {*}[.t tag names]
+} -result {sel a d b c}
+test textTag-7.6 {TkTextTagCmd - "lower" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete {*}[.t tag names]
+ .t tag remove sel 1.0 end
+ foreach i {a b c d} {
+ .t tag configure $i -background black
+ }
+} -body {
.t tag lower a c
.t tag names
-} {sel b a c d}
+} -cleanup {
+ .t tag delete {*}[.t tag names]
+} -result {sel b a c d}
-test textTag-8.1 {TkTextTagCmd - "names" option} haveCourier12 {
- list [catch {.t tag names a b} msg] $msg
-} {1 {wrong # args: should be ".t tag names ?index?"}}
-test textTag-8.2 {TkTextTagCmd - "names" option} haveCourier12 {
- tagsetup
+
+test textTag-8.1 {TkTextTagCmd - "names" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag names a b
+} -cleanup {
+ .t tag delete {*}[.t tag names]
+} -returnCodes error -result {wrong # args: should be ".t tag names ?index?"}
+test textTag-8.2 {TkTextTagCmd - "names" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete {*}[.t tag names]
+ .t tag remove sel 1.0 end
+ foreach i {a b c d} {
+ .t tag configure $i -background black
+ }
+} -body {
.t tag names
-} {sel a b c d}
-test textTag-8.3 {TkTextTagCmd - "names" option} haveCourier12 {
- tagsetup
+} -cleanup {
+ .t tag delete {*}[.t tag names]
+} -result {sel a b c d}
+test textTag-8.3 {TkTextTagCmd - "names" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete {*}[.t tag names]
+ .t tag remove sel 1.0 end
+ foreach i {a b c d} {
+ .t tag configure $i -background black
+ }
+} -body {
.t tag add "a b" 2.1 2.6
.t tag add c 2.4 2.7
.t tag names 2.5
-} {c {a b}}
-
-.t tag delete x y z a b c d {a b}
-.t tag add x 2.3 2.5
-.t tag add x 2.9 3.1
-.t tag add x 7.2
-test textTag-9.1 {TkTextTagCmd - "nextrange" option} haveCourier12 {
- list [catch {.t tag nextrange x} msg] $msg
-} {1 {wrong # args: should be ".t tag nextrange tagName index1 ?index2?"}}
-test textTag-9.2 {TkTextTagCmd - "nextrange" option} haveCourier12 {
- list [catch {.t tag nextrange x 1 2 3} msg] $msg
-} {1 {wrong # args: should be ".t tag nextrange tagName index1 ?index2?"}}
-test textTag-9.3 {TkTextTagCmd - "nextrange" option} haveCourier12 {
- list [catch {.t tag nextrange foo 1.0} msg] $msg
-} {0 {}}
-test textTag-9.4 {TkTextTagCmd - "nextrange" option} haveCourier12 {
- list [catch {.t tag nextrange x foo} msg] $msg
-} {1 {bad text index "foo"}}
-test textTag-9.5 {TkTextTagCmd - "nextrange" option} haveCourier12 {
- list [catch {.t tag nextrange x 1.0 bar} msg] $msg
-} {1 {bad text index "bar"}}
-test textTag-9.6 {TkTextTagCmd - "nextrange" option} haveCourier12 {
+} -cleanup {
+ .t tag delete {*}[.t tag names]
+} -result {c {a b}}
+
+
+test textTag-9.1 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag nextrange x
+} -returnCodes error -result {wrong # args: should be ".t tag nextrange tagName index1 ?index2?"}
+test textTag-9.2 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag nextrange x 1 2 3
+} -returnCodes error -result {wrong # args: should be ".t tag nextrange tagName index1 ?index2?"}
+test textTag-9.3 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag nextrange foo 1.0
+} -returnCodes ok -result {}
+test textTag-9.4 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag nextrange x foo
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {bad text index "foo"}
+test textTag-9.5 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
+ .t tag nextrange x 1.0 bar
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {bad text index "bar"}
+test textTag-9.6 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
.t tag nextrange x 1.0
-} {2.3 2.5}
-test textTag-9.7 {TkTextTagCmd - "nextrange" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {2.3 2.5}
+test textTag-9.7 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
.t tag nextrange x 2.2
-} {2.3 2.5}
-test textTag-9.8 {TkTextTagCmd - "nextrange" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {2.3 2.5}
+test textTag-9.8 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
.t tag nextrange x 2.3
-} {2.3 2.5}
-test textTag-9.9 {TkTextTagCmd - "nextrange" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {2.3 2.5}
+test textTag-9.9 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
.t tag nextrange x 2.4
-} {2.9 3.1}
-test textTag-9.10 {TkTextTagCmd - "nextrange" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {2.9 3.1}
+test textTag-9.10 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
.t tag nextrange x 2.4 2.9
-} {}
-test textTag-9.11 {TkTextTagCmd - "nextrange" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {}
+test textTag-9.11 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
.t tag nextrange x 2.4 2.10
-} {2.9 3.1}
-test textTag-9.12 {TkTextTagCmd - "nextrange" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {2.9 3.1}
+test textTag-9.12 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
.t tag nextrange x 2.4 2.11
-} {2.9 3.1}
-test textTag-9.13 {TkTextTagCmd - "nextrange" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {2.9 3.1}
+test textTag-9.13 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
.t tag nextrange x 7.0
-} {7.2 7.3}
-test textTag-9.14 {TkTextTagCmd - "nextrange" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {7.2 7.3}
+test textTag-9.14 {TkTextTagCmd - "nextrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
.t tag nextrange x 7.3
-} {}
-
-test textTag-10.1 {TkTextTagCmd - "prevrange" option} haveCourier12 {
- list [catch {.t tag prevrange x} msg] $msg
-} {1 {wrong # args: should be ".t tag prevrange tagName index1 ?index2?"}}
-test textTag-10.2 {TkTextTagCmd - "prevrange" option} haveCourier12 {
- list [catch {.t tag prevrange x 1 2 3} msg] $msg
-} {1 {wrong # args: should be ".t tag prevrange tagName index1 ?index2?"}}
-test textTag-10.3 {TkTextTagCmd - "prevrange" option} haveCourier12 {
- list [catch {.t tag prevrange foo end} msg] $msg
-} {0 {}}
-test textTag-10.4 {TkTextTagCmd - "prevrange" option} haveCourier12 {
- list [catch {.t tag prevrange x foo} msg] $msg
-} {1 {bad text index "foo"}}
-test textTag-10.5 {TkTextTagCmd - "prevrange" option} haveCourier12 {
- list [catch {.t tag prevrange x end bar} msg] $msg
-} {1 {bad text index "bar"}}
-test textTag-10.6 {TkTextTagCmd - "prevrange" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {}
+
+
+test textTag-10.1 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag prevrange x
+} -returnCodes error -result {wrong # args: should be ".t tag prevrange tagName index1 ?index2?"}
+test textTag-10.2 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag prevrange x 1 2 3
+} -returnCodes error -result {wrong # args: should be ".t tag prevrange tagName index1 ?index2?"}
+test textTag-10.3 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag prevrange foo end
+} -cleanup {
+ .t tag delete x
+} -returnCodes ok -result {}
+test textTag-10.4 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
+ .t tag prevrange x foo
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {bad text index "foo"}
+test textTag-10.5 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
+ .t tag prevrange x end bar
+} -cleanup {
+ .t tag delete x
+} -returnCodes error -result {bad text index "bar"}
+test textTag-10.6 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
.t tag prevrange x end
-} {7.2 7.3}
-test textTag-10.7 {TkTextTagCmd - "prevrange" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {7.2 7.3}
+test textTag-10.7 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
.t tag prevrange x 2.4
-} {2.3 2.5}
-test textTag-10.8 {TkTextTagCmd - "prevrange" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {2.3 2.5}
+test textTag-10.8 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
.t tag prevrange x 2.5
-} {2.3 2.5}
-test textTag-10.9 {TkTextTagCmd - "prevrange" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {2.3 2.5}
+test textTag-10.9 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
.t tag prevrange x 2.9
-} {2.3 2.5}
-test textTag-10.10 {TkTextTagCmd - "prevrange" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {2.3 2.5}
+test textTag-10.10 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
.t tag prevrange x 2.9 2.6
-} {}
-test textTag-10.11 {TkTextTagCmd - "prevrange" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {}
+test textTag-10.11 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
.t tag prevrange x 2.9 2.5
-} {}
-test textTag-10.12 {TkTextTagCmd - "prevrange" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {}
+test textTag-10.12 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
.t tag prevrange x 2.9 2.3
-} {2.3 2.5}
-test textTag-10.13 {TkTextTagCmd - "prevrange" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {2.3 2.5}
+test textTag-10.13 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
.t tag prevrange x 7.0
-} {2.9 3.1}
-test textTag-10.14 {TkTextTagCmd - "prevrange" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {2.9 3.1}
+test textTag-10.14 {TkTextTagCmd - "prevrange" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete x
+} -body {
+ .t tag add x 2.3 2.5
+ .t tag add x 2.9 3.1
+ .t tag add x 7.2
.t tag prevrange x 2.3
-} {}
-
-test textTag-11.1 {TkTextTagCmd - "raise" option} haveCourier12 {
- list [catch {.t tag raise} msg] $msg
-} {1 {wrong # args: should be ".t tag raise tagName ?aboveThis?"}}
-test textTag-11.2 {TkTextTagCmd - "raise" option} haveCourier12 {
- list [catch {.t tag raise foo} msg] $msg
-} {1 {tag "foo" isn't defined in text widget}}
-test textTag-11.3 {TkTextTagCmd - "raise" option} haveCourier12 {
- list [catch {.t tag raise sel bar} msg] $msg
-} {1 {tag "bar" isn't defined in text widget}}
-test textTag-11.4 {TkTextTagCmd - "raise" option} haveCourier12 {
- tagsetup
+} -cleanup {
+ .t tag delete x
+} -result {}
+
+
+test textTag-11.1 {TkTextTagCmd - "raise" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag raise
+} -returnCodes error -result {wrong # args: should be ".t tag raise tagName ?aboveThis?"}
+test textTag-11.2 {TkTextTagCmd - "raise" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag raise foo
+} -returnCodes error -result {tag "foo" isn't defined in text widget}
+test textTag-11.3 {TkTextTagCmd - "raise" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag raise sel bar
+} -returnCodes error -result {tag "bar" isn't defined in text widget}
+test textTag-11.4 {TkTextTagCmd - "raise" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete {*}[.t tag names]
+ .t tag remove sel 1.0 end
+ foreach i {a b c d} {
+ .t tag configure $i -background black
+ }
+} -body {
.t tag raise c
.t tag names
-} {sel a b d c}
-test textTag-11.5 {TkTextTagCmd - "raise" option} haveCourier12 {
- tagsetup
+} -cleanup {
+ .t tag delete {*}[.t tag names]
+} -result {sel a b d c}
+test textTag-11.5 {TkTextTagCmd - "raise" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete {*}[.t tag names]
+ .t tag remove sel 1.0 end
+ foreach i {a b c d} {
+ .t tag configure $i -background black
+ }
+} -body {
.t tag raise d b
.t tag names
-} {sel a b d c}
-test textTag-11.6 {TkTextTagCmd - "raise" option} haveCourier12 {
- tagsetup
+} -cleanup {
+ .t tag delete {*}[.t tag names]
+} -result {sel a b d c}
+test textTag-11.6 {TkTextTagCmd - "raise" option} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete {*}[.t tag names]
+ .t tag remove sel 1.0 end
+ foreach i {a b c d} {
+ .t tag configure $i -background black
+ }
+} -body {
.t tag raise a c
.t tag names
-} {sel b c a d}
+} -cleanup {
+ .t tag delete {*}[.t tag names]
+} -result {sel b c a d}
-test textTag-12.1 {TkTextTagCmd - "ranges" option} haveCourier12 {
- list [catch {.t tag ranges} msg] $msg
-} {1 {wrong # args: should be ".t tag ranges tagName"}}
-test textTag-12.2 {TkTextTagCmd - "ranges" option} haveCourier12 {
+
+test textTag-12.1 {TkTextTagCmd - "ranges" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag ranges
+} -returnCodes error -result {wrong # args: should be ".t tag ranges tagName"}
+test textTag-12.2 {TkTextTagCmd - "ranges" option} -constraints {
+ haveCourier12
+} -body {
.t tag delete x
.t tag ranges x
-} {}
-test textTag-12.3 {TkTextTagCmd - "ranges" option} haveCourier12 {
+} -result {}
+test textTag-12.3 {TkTextTagCmd - "ranges" option} -constraints {
+ haveCourier12
+} -setup {
.t tag delete x
+} -body {
.t tag add x 2.2
.t tag add x 2.7 4.15
.t tag add x 5.2 5.5
.t tag ranges x
-} {2.2 2.3 2.7 4.6 5.2 5.5}
-test textTag-12.4 {TkTextTagCmd - "ranges" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {2.2 2.3 2.7 4.6 5.2 5.5}
+test textTag-12.4 {TkTextTagCmd - "ranges" option} -constraints {
+ haveCourier12
+} -setup {
.t tag delete x
+} -body {
.t tag add x 1.0 3.0
.t tag add x 4.0 end
.t tag ranges x
-} {1.0 3.0 4.0 8.0}
+} -cleanup {
+ .t tag delete x
+} -result {1.0 3.0 4.0 8.0}
-test textTag-13.1 {TkTextTagCmd - "remove" option} haveCourier12 {
- list [catch {.t tag remove} msg] $msg
-} {1 {wrong # args: should be ".t tag remove tagName index1 ?index2 index1 index2 ...?"}}
-test textTag-13.2 {TkTextTagCmd - "remove" option} haveCourier12 {
+
+test textTag-13.1 {TkTextTagCmd - "remove" option} -constraints {
+ haveCourier12
+} -body {
+ .t tag remove
+} -returnCodes error -result {wrong # args: should be ".t tag remove tagName index1 ?index2 index1 index2 ...?"}
+test textTag-13.2 {TkTextTagCmd - "remove" option} -constraints {
+ haveCourier12
+} -setup {
.t tag delete x
+} -body {
.t tag add x 2.2 2.11
.t tag remove x 2.3 2.7
.t tag ranges x
-} {2.2 2.3 2.7 2.11}
-test textTag-13.3 {TkTextTagCmd - "remove" option} haveCourier12 {
+} -cleanup {
+ .t tag delete x
+} -result {2.2 2.3 2.7 2.11}
+test textTag-13.3 {TkTextTagCmd - "remove" option} -constraints {
+ haveCourier12
+} -setup {
+ destroy .t.e
+} -body {
+ entry .t.e
+ .t.e insert 0 "Text"
.t configure -exportselection 1
.t tag remove sel 1.0 end
.t tag add sel 2.4 3.3
.t.e select to 4
.t tag remove sel 2.7 3.1
selection get
-} Text
+} -cleanup {
+ destroy .t.e
+} -result {Text}
-.t tag delete x a b c d
-test textTag-14.1 {SortTags} haveCourier12 {
+
+test textTag-14.1 {SortTags} -constraints haveCourier12 -setup {
+ .t tag delete a b c d
+} -body {
foreach i {a b c d} {
- .t tag add $i 2.0 2.2
+ .t tag add $i 2.0 2.2
}
.t tag names 2.1
-} {a b c d}
+} -cleanup {
+ .t tag delete a b c d
+} -result {a b c d}
.t tag delete a b c d
-test textTag-14.2 {SortTags} haveCourier12 {
+test textTag-14.2 {SortTags} -constraints haveCourier12 -setup {
+ .t tag delete a b c d
+} -body {
foreach i {a b c d} {
- .t tag configure $i -background black
+ .t tag configure $i -background black
}
foreach i {d c b a} {
- .t tag add $i 2.0 2.2
+ .t tag add $i 2.0 2.2
}
.t tag names 2.1
-} {a b c d}
-.t tag delete x a b c d
-test textTag-14.3 {SortTags} haveCourier12 {
+} -cleanup {
+ .t tag delete a b c d
+} -result {a b c d}
+test textTag-14.3 {SortTags} -constraints haveCourier12 -setup {
+ .t tag delete {*}[.t tag names]
+} -body {
for {set i 0} {$i < 30} {incr i} {
- .t tag add x$i 2.0 2.2
+ .t tag add x$i 2.0 2.2
}
.t tag names 2.1
-} {x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29}
-test textTag-14.4 {SortTags} haveCourier12 {
+} -cleanup {
+ .t tag delete {*}[.t tag names]
+} -result {x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29}
+test textTag-14.4 {SortTags} -constraints haveCourier12 -setup {
+ .t tag delete {*}[.t tag names]
+} -body {
for {set i 0} {$i < 30} {incr i} {
- .t tag configure x$i -background black
+ .t tag configure x$i -background black
}
for {set i 29} {$i >= 0} {incr i -1} {
- .t tag add x$i 2.0 2.2
+ .t tag add x$i 2.0 2.2
}
.t tag names 2.1
-} {x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29}
+} -cleanup {
+ .t tag delete {*}[.t tag names]
+} -result {x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29}
+
+
-foreach tag [.t tag names] {
- catch {.t tag delete $tag}
-}
set c [.t bbox 2.1]
set x1 [expr [lindex $c 0] + [lindex $c 2]/2]
set y1 [expr [lindex $c 1] + [lindex $c 3]/2]
@@ -587,7 +1336,9 @@ set c [.t bbox 4.3]
set x3 [expr [lindex $c 0] + [lindex $c 2]/2]
set y3 [expr [lindex $c 1] + [lindex $c 3]/2]
-test textTag-15.1 {TkTextBindProc} haveCourier12 {
+test textTag-15.1 {TkTextBindProc} -constraints haveCourier12 -setup {
+ .t tag delete x y
+} -body {
bind .t <ButtonRelease> {lappend x up}
.t tag bind x <ButtonRelease> {lappend x x-up}
.t tag bind y <ButtonRelease> {lappend x y-up}
@@ -603,12 +1354,15 @@ test textTag-15.1 {TkTextBindProc} haveCourier12 {
event gen .t <Button> -x $x2 -y $y2
event gen .t <Motion> -x $x3 -y $y3
event gen .t <ButtonRelease> -x $x3 -y $y3
+ return $x
+} -cleanup {
+ .t tag delete x y
bind .t <ButtonRelease> {}
- set x
-} {x-up up up y-up up}
-test textTag-15.2 {TkTextBindProc} haveCourier12 {
- catch {.t tag delete x}
- catch {.t tag delete y}
+} -result {x-up up up y-up up}
+
+test textTag-15.2 {TkTextBindProc} -constraints haveCourier12 -setup {
+ .t tag delete x y
+} -body {
.t tag bind x <Enter> {lappend x x-enter}
.t tag bind x <ButtonPress> {lappend x x-down}
.t tag bind x <ButtonRelease> {lappend x x-up}
@@ -628,11 +1382,14 @@ test textTag-15.2 {TkTextBindProc} haveCourier12 {
event gen .t <Motion> -x $x3 -y $y3 -state 0x100
lappend x |
event gen .t <ButtonRelease> -x $x3 -y $y3
- set x
-} {x-enter | x-down | | x-up x-leave y-enter}
-test textTag-15.3 {TkTextBindProc} haveCourier12 {
- catch {.t tag delete x}
- catch {.t tag delete y}
+ return $x
+} -cleanup {
+ .t tag delete x y
+} -result {x-enter | x-down | | x-up x-leave y-enter}
+
+test textTag-15.3 {TkTextBindProc} -constraints haveCourier12 -setup {
+ .t tag delete x y
+} -body {
.t tag bind x <Enter> {lappend x x-enter}
.t tag bind x <Any-ButtonPress-1> {lappend x x-down}
.t tag bind x <Any-ButtonRelease-1> {lappend x x-up}
@@ -656,14 +1413,17 @@ test textTag-15.3 {TkTextBindProc} haveCourier12 {
event gen .t <ButtonRelease-1> -x $x3 -y $y3 -state 0x300
lappend x |
event gen .t <ButtonRelease-2> -x $x3 -y $y3 -state 0x200
- set x
-} {x-enter | x-down | | | x-up | x-leave y-enter}
-
-foreach tag [.t tag names] {
- catch {.t tag delete $tag}
-}
-.t tag configure big -font $bigFont
-test textTag-16.1 {TkTextPickCurrent procedure} haveCourier12 {
+ return $x
+} -cleanup {
+ .t tag delete x y
+} -result {x-enter | x-down | | | x-up | x-leave y-enter}
+
+
+test textTag-16.1 {TkTextPickCurrent procedure} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete {*}[.t tag names]
+} -body {
event gen .t <ButtonRelease-1> -state 0x100 -x $x1 -y $y1
set x [.t index current]
event gen .t <Motion> -x $x2 -y $y2
@@ -678,23 +1438,34 @@ test textTag-16.1 {TkTextPickCurrent procedure} haveCourier12 {
lappend x [.t index current]
event gen .t <ButtonRelease-1> -state 0x100 -x $x3 -y $y3
lappend x [.t index current]
-} {2.1 3.2 3.2 3.2 3.2 3.2 4.3}
-test textTag-16.2 {TkTextPickCurrent procedure} haveCourier12 {
+} -result {2.1 3.2 3.2 3.2 3.2 3.2 4.3}
+
+test textTag-16.2 {TkTextPickCurrent procedure} -constraints {
+ haveCourier12
+} -setup {
+ .t tag delete {*}[.t tag names]
+} -body {
+ .t tag configure big -font $bigFont
event gen .t <ButtonRelease-1> -state 0x100 -x $x1 -y $y1
event gen .t <Motion> -x $x2 -y $y2
set x [.t index current]
.t tag add big 3.0
update
lappend x [.t index current]
-} {3.2 3.1}
-.t tag remove big 1.0 end
-foreach i {a b c d} {
- .t tag bind $i <Enter> "lappend x enter-$i"
- .t tag bind $i <Leave> "lappend x leave-$i"
-}
-test textTag-16.3 {TkTextPickCurrent procedure} haveCourier12 {
+} -cleanup {
+ .t tag delete big
+} -result {3.2 3.1}
+
+test textTag-16.3 {TkTextPickCurrent procedure} -constraints {
+ haveCourier12
+} -setup {
foreach i {a b c d} {
- .t tag remove $i 1.0 end
+ .t tag remove $i 1.0 end
+ }
+} -body {
+ foreach i {a b c d} {
+ .t tag bind $i <Enter> "lappend x enter-$i"
+ .t tag bind $i <Leave> "lappend x leave-$i"
}
.t tag lower b
.t tag lower a
@@ -708,11 +1479,21 @@ test textTag-16.3 {TkTextPickCurrent procedure} haveCourier12 {
event gen .t <Motion> -x $x2 -y $y2
lappend x |
event gen .t <Motion> -x $x3 -y $y3
- set x
-} {enter-a enter-b | leave-b enter-c | leave-a leave-c}
-test textTag-16.4 {TkTextPickCurrent procedure} haveCourier12 {
+ return $x
+} -cleanup {
+ .t tag delete {*}[.t tag names]
+} -result {enter-a enter-b | leave-b enter-c | leave-a leave-c}
+
+test textTag-16.4 {TkTextPickCurrent procedure} -constraints {
+ haveCourier12
+} -setup {
foreach i {a b c d} {
- .t tag remove $i 1.0 end
+ .t tag remove $i 1.0 end
+ }
+} -body {
+ foreach i {a b c d} {
+ .t tag bind $i <Enter> "lappend x enter-$i"
+ .t tag bind $i <Leave> "lappend x leave-$i"
}
.t tag lower b
.t tag lower a
@@ -725,55 +1506,82 @@ test textTag-16.4 {TkTextPickCurrent procedure} haveCourier12 {
lappend x |
.t tag lower c
event gen .t <Motion> -x $x2 -y $y2
- set x
-} {enter-a enter-b enter-c | leave-c leave-b}
-foreach i {a b c d} {
- .t tag delete $i
-}
-test textTag-16.5 {TkTextPickCurrent procedure} haveCourier12 {
- foreach i {a b c d} {
- .t tag remove $i 1.0 end
+ return $x
+} -cleanup {
+ .t tag delete {*}[.t tag names]
+} -result {enter-a enter-b enter-c | leave-c leave-b}
+
+test textTag-16.5 {TkTextPickCurrent procedure} -constraints {
+ haveCourier12
+} -setup {
+ foreach i {big a b c d} {
+ .t tag remove $i 1.0 end
}
+} -body {
+ .t tag configure big -font $bigFont
event gen .t <Motion> -x $x1 -y $y1
.t tag bind a <Enter> {.t tag add big 3.0 3.2}
.t tag add a 3.2
event gen .t <Motion> -x $x2 -y $y2
.t index current
-} {3.2}
-test textTag-16.6 {TkTextPickCurrent procedure} haveCourier12 {
- foreach i {a b c d} {
- .t tag remove $i 1.0 end
+} -cleanup {
+ .t tag delete a big
+} -result {3.2}
+
+test textTag-16.6 {TkTextPickCurrent procedure} -constraints {
+ haveCourier12
+} -setup {
+ foreach i {big a b c d} {
+ .t tag remove $i 1.0 end
}
+} -body {
+ .t tag configure big -font $bigFont
event gen .t <Motion> -x $x1 -y $y1
.t tag bind a <Enter> {.t tag add big 3.0 3.2}
.t tag add a 3.2
event gen .t <Motion> -x $x2 -y $y2
update
.t index current
-} {3.1}
-test textTag-16.7 {TkTextPickCurrent procedure} haveCourier12 {
- foreach i {a b c d} {
- .t tag remove $i 1.0 end
+} -cleanup {
+ .t tag delete a big
+} -result {3.1}
+
+test textTag-16.7 {TkTextPickCurrent procedure} -constraints {
+ haveCourier12
+} -setup {
+ foreach i {big a b c d} {
+ .t tag remove $i 1.0 end
}
+} -body {
+ .t tag configure big -font $bigFont
+ .t tag bind a <Enter> {.t tag add big 3.0 3.2}
+ .t tag add a 3.2
+
event gen .t <Motion> -x $x1 -y $y1
.t tag bind a <Leave> {.t tag add big 3.0 3.2}
.t tag add a 2.1
event gen .t <Motion> -x $x2 -y $y2
+ update
.t index current
-} {3.1}
+} -cleanup {
+ .t tag delete a big
+} -result {3.1}
+
-test textTag-17.1 {insert procedure inserts tags} {
+test textTag-17.1 {insert procedure inserts tags} -setup {
.t delete 1.0 end
+} -body {
# Objectification of the text widget had a problem
# with inserting tags when using 'end'. Check that
# bug has been fixed.
.t insert end abcd {x} \n {} efgh {y} \n {}
.t dump -tag 1.0 end
-} {tagon x 1.0 tagoff x 1.4 tagon y 2.0 tagoff y 2.4}
+} -result {tagon x 1.0 tagoff x 1.4 tagon y 2.0 tagoff y 2.4}
-catch {destroy .t}
-test textTag-18.1 {TkTextPickCurrent tag bindings} {
+test textTag-18.1 {TkTextPickCurrent tag bindings} -setup {
+ destroy .t
+} -body {
text .t -width 30 -height 4 -relief sunken -borderwidth 10 \
-highlightthickness 10 -pady 2
pack .t
@@ -794,11 +1602,18 @@ test textTag-18.1 {TkTextPickCurrent tag bindings} {
event gen .t <Motion> -warp 1 -x 20 -y 20 ; update
event gen .t <Motion> -warp 1 -x 10 -y 10 ; update
event gen .t <Motion> -warp 1 -x 25 -y 25 ; update
- set res
-} {Enter {25 25 tag-Enter} {20 20 tag-Leave} {25 25 tag-Enter}}
+ return $res
+} -cleanup {
+ destroy .t
+} -result {Enter {25 25 tag-Enter} {20 20 tag-Leave} {25 25 tag-Enter}}
-catch {destroy .t}
+destroy .t
# cleanup
cleanupTests
return
+
+
+
+
+
diff --git a/tests/unixMenu.test b/tests/unixMenu.test
index a56b62e..e354006 100644
--- a/tests/unixMenu.test
+++ b/tests/unixMenu.test
@@ -7,476 +7,650 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: unixMenu.test,v 1.10 2007/05/09 12:52:44 das Exp $
+# RCS: @(#) $Id: unixMenu.test,v 1.11 2008/08/28 08:52:07 aniap Exp $
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
-test unixMenu-1.1 {TkpNewMenu - normal menu} unix {
- catch {destroy .m1}
- list [catch {menu .m1} msg] $msg [destroy .m1]
-} {0 .m1 {}}
-test unixMenu-1.2 {TkpNewMenu - help menu} unix {
- catch {destroy .m1}
+
+test unixMenu-1.1 {TkpNewMenu - normal menu} -constraints unix -setup {
+ destroy .m1
+} -body {
+ list [menu .m1] [destroy .m1]
+} -returnCodes ok -result {.m1 {}}
+test unixMenu-1.2 {TkpNewMenu - help menu} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
. configure -menu .m1
.m1 add cascade -label Help -menu .m1.help
- list [catch {menu .m1.help} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 .m1.help {} {}}
+ list [menu .m1.help] [. configure -menu ""] [destroy .m1]
+} -returnCodes ok -result {.m1.help {} {}}
+
+
+test unixMenu-2.1 {TkpDestroyMenu - nothing to do} -constraints unix -body {}
-test unixMenu-2.1 {TkpDestroyMenu - nothing to do} {} {}
-test unixMenu-3.1 {TkpDestroymenuEntry - nothing to do} {} {}
-test unixMenu-4.1 {TkpConfigureMenuEntry - non-cascade entry} unix {
- catch {destroy .m1}
+test unixMenu-3.1 {TkpDestroymenuEntry - nothing to do} -constraints unix -body {}
+
+
+test unixMenu-4.1 {TkpConfigureMenuEntry - non-cascade entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
.m1 add command -label test
- list [catch {.m1 entryconfigure test -label foo} msg] $msg [destroy .m1]
-} {0 {} {}}
-test unixMenu-4.2 {TkpConfigureMenuEntry - cascade entry} unix {
- catch {destroy .m1}
+ list [.m1 entryconfigure test -label foo] [destroy .m1]
+} -returnCodes ok -result {{} {}}
+test unixMenu-4.2 {TkpConfigureMenuEntry - cascade entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
.m1 add cascade -menu .m2 -label test
menu .m1.foo -tearoff 0
- list [catch {.m1 entryconfigure test -menu .m1.foo} msg] $msg [destroy .m1]
-} {0 {} {}}
+ list [.m1 entryconfigure test -menu .m1.foo] [destroy .m1]
+} -returnCodes ok -result {{} {}}
+
-test unixMenu-5.1 {TkpMenuNewEntry - nothing to do} {} {}
+test unixMenu-5.1 {TkpMenuNewEntry - nothing to do} -constraints unix -body {}
-test unixMenu-6.1 {TkpSetWindowMenuBar - null menu} unix {
- catch {destroy .m1}
+
+test unixMenu-6.1 {TkpSetWindowMenuBar - null menu} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add cascade -label foo
. configure -menu .m1
- list [catch {. configure -menu ""} msg] $msg [destroy .m1]
-} {0 {} {}}
-test unixMenu-6.2 {TkpSetWindowMenuBar - menu} unix {
- catch {destroy .m1}
+ list [. configure -menu ""] [destroy .m1]
+} -returnCodes ok -result {{} {}}
+test unixMenu-6.2 {TkpSetWindowMenuBar - menu} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add cascade -label foo
- list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
+ list [. configure -menu .m1] [. configure -menu ""] [destroy .m1]
+} -returnCodes ok -result {{} {} {}}
+
+
+test unixMenu-7.1 {TkpSetMainMenubar - nothing to do} -constraints unix -body {}
-test unixMenu-7.1 {TkpSetMainMenubar - nothing to do} {} {}
-test unixMenu-8.1 {GetMenuIndicatorGeometry - indicator off} unix {
- catch {destroy .m1}
+test unixMenu-8.1 {GetMenuIndicatorGeometry - indicator off} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add checkbutton -label foo -indicatoron 0
- list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1]
-} {0 {}}
-test unixMenu-8.2 {GetMenuIndicatorGeometry - not checkbutton or radio} unix {
- catch {destroy .m1}
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+test unixMenu-8.2 {GetMenuIndicatorGeometry - not checkbutton or radio} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label foo
- list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1]
-} {0 {}}
-test unixMenu-8.3 {GetMenuIndicatorGeometry - checkbutton image} {unix testImageType} {
- catch {destroy .m1}
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+test unixMenu-8.3 {GetMenuIndicatorGeometry - checkbutton image} -constraints {
+ unix testImageType
+} -setup {
+ destroy .m1
catch {image delete image1}
+} -body {
menu .m1
image create test image1
.m1 add checkbutton -image image1 -label foo
.m1 invoke foo
- list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] [image delete image1]
-} {0 {} {}}
-test unixMenu-8.4 {GetMenuIndicatorGeometry - checkbutton bitmap} unix {
- catch {destroy .m1}
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -cleanup {
+ image delete image1
+} -returnCodes ok
+test unixMenu-8.4 {GetMenuIndicatorGeometry - checkbutton bitmap} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add checkbutton -bitmap questhead -label foo
.m1 invoke foo
- list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1]
-} {0 {}}
-test unixMenu-8.5 {GetMenuIndicatorGeometry - checkbutton} unix {
- catch {destroy .m1}
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+test unixMenu-8.5 {GetMenuIndicatorGeometry - checkbutton} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add checkbutton -label foo
.m1 invoke foo
- list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1]
-} {0 {}}
-test unixMenu-8.6 {GetMenuIndicatorGeometry - radiobutton image} {unix testImageType} {
- catch {destroy .m1}
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+test unixMenu-8.6 {GetMenuIndicatorGeometry - radiobutton image} -constraints {
+ unix testImageType
+} -setup {
+ destroy .m1
catch {image delete image1}
+} -body {
menu .m1
image create test image1
.m1 add radiobutton -image image1 -label foo
.m1 invoke foo
- list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] [image delete image1]
-} {0 {} {}}
-test unixMenu-8.7 {GetMenuIndicatorGeometry - radiobutton bitmap} unix {
- catch {destroy .m1}
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+ image delete image1
+} -returnCodes ok
+test unixMenu-8.7 {GetMenuIndicatorGeometry - radiobutton bitmap} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add radiobutton -bitmap questhead -label foo
.m1 invoke foo
- list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1]
-} {0 {}}
-test unixMenu-8.8 {GetMenuIndicatorGeometry - radiobutton} unix {
- catch {destroy .m1}
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+test unixMenu-8.8 {GetMenuIndicatorGeometry - radiobutton} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add radiobutton -label foo
.m1 invoke foo
- list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1]
-} {0 {}}
-test unixMenu-8.9 {GetMenuIndicatorGeometry - hideMargin} unix {
- catch {destroy .m1}
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+test unixMenu-8.9 {GetMenuIndicatorGeometry - hideMargin} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add radiobutton -label foo -hidemargin 1
.m1 invoke foo
- list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1]
-} {0 {}}
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
-test unixMenu-9.1 {GetMenuAccelGeometry - cascade entry} unix {
- catch {destroy .m1}
+
+test unixMenu-9.1 {GetMenuAccelGeometry - cascade entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add cascade -label foo
- list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1]
-} {0 {}}
-test unixMenu-9.2 {GetMenuAccelGeometry - non-null label} unix {
- catch {destroy .m1}
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+test unixMenu-9.2 {GetMenuAccelGeometry - non-null label} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label foo -accel "Ctrl+S"
- list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1]
-} {0 {}}
-test unixMenu-9.3 {GetMenuAccelGeometry - null label} unix {
- catch {destroy .m1}
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+test unixMenu-9.3 {GetMenuAccelGeometry - null label} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label foo
- list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1]
-} {0 {}}
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+
-test unixMenu-10.1 {DrawMenuEntryBackground - active menubar} unix {
- catch {destroy .m1}
+test unixMenu-10.1 {DrawMenuEntryBackground - active menubar} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add cascade -label foo
. configure -menu .m1
.m1 activate 1
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test unixMenu-10.2 {DrawMenuEntryBackground - active} unix {
- catch {destroy .m1}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -returnCodes ok -result {{} {} {}}
+test unixMenu-10.2 {DrawMenuEntryBackground - active} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label foo
set tearoff [tk::TearOffMenu .m1 40 40]
$tearoff activate 0
- list [catch {update} msg] $msg [destroy .m1]
-} {0 {} {}}
-test unixMenu-10.3 {DrawMenuEntryBackground - non-active} unix {
- catch {destroy .m1}
+ list [update] [destroy .m1]
+} -returnCodes ok -result {{} {}}
+test unixMenu-10.3 {DrawMenuEntryBackground - non-active} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label foo
set tearoff [tk::TearOffMenu .m1 40 40]
- list [catch {update} msg] $msg [destroy .m1]
-} {0 {} {}}
+ list [update] [destroy .m1]
+} -returnCodes ok -result {{} {}}
+
-test unixMenu-11.1 {DrawMenuEntryAccelerator - menubar} unix {
- catch {destroy .m1}
+test unixMenu-11.1 {DrawMenuEntryAccelerator - menubar} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label foo -accel "Ctrl+U"
. configure -menu .m1
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
# drawArrow parameter is never false under Unix
-test unixMenu-11.2 {DrawMenuEntryAccelerator - cascade entry} unix {
- catch {destroy .m1}
+test unixMenu-11.2 {DrawMenuEntryAccelerator - cascade entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add cascade -label foo
set tearoff [tk::TearOffMenu .m1 40 40]
- list [catch {update} msg] $msg [destroy .m1]
-} {0 {} {}}
-test unixMenu-11.3 {DrawMenuEntryAccelerator - normal entry} unix {
- catch {destroy .m1}
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-11.3 {DrawMenuEntryAccelerator - normal entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label foo -accel "Ctrl+U"
set tearoff [tk::TearOffMenu .m1 40 40]
- list [catch {update} msg] $msg [destroy .m1]
-} {0 {} {}}
-test unixMenu-11.4 {DrawMenuEntryAccelerator - null entry} unix {
- catch {destroy .m1}
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-11.4 {DrawMenuEntryAccelerator - null entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label foo
set tearoff [tk::TearOffMenu .m1 40 40]
- list [catch {update} msg] $msg [destroy .m1]
-} {0 {} {}}
+ list [update] [destroy .m1]
+} -result {{} {}}
+
-test unixMenu-12.1 {DrawMenuEntryIndicator - non-check or radio} unix {
- catch {destroy .m1}
+test unixMenu-12.1 {DrawMenuEntryIndicator - non-check or radio} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label foo
set tearoff [tk::TearOffMenu .m1 40 40]
- list [catch {update} msg] $msg [destroy .m1]
-} {0 {} {}}
-test unixMenu-12.2 {DrawMenuEntryIndicator - checkbutton - indicator off} unix {
- catch {destroy .m1}
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-12.2 {DrawMenuEntryIndicator - checkbutton - indicator off} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add checkbutton -label foo -indicatoron 0
set tearoff [tk::TearOffMenu .m1 40 40]
- list [catch {update} msg] $msg [destroy .m1]
-} {0 {} {}}
-test unixMenu-12.3 {DrawMenuEntryIndicator - checkbutton - not selected} unix {
- catch {destroy .m1}
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-12.3 {DrawMenuEntryIndicator - checkbutton - not selected} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add checkbutton -label foo
set tearoff [tk::TearOffMenu .m1 40 40]
- list [catch {update} msg] $msg [destroy .m1]
-} {0 {} {}}
-test unixMenu-12.4 {DrawMenuEntryIndicator - checkbutton - selected} unix {
- catch {destroy .m1}
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-12.4 {DrawMenuEntryIndicator - checkbutton - selected} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add checkbutton -label foo
.m1 invoke 1
set tearoff [tk::TearOffMenu .m1 40 40]
- list [catch {update} msg] $msg [destroy .m1]
-} {0 {} {}}
-test unixMenu-12.5 {DrawMenuEntryIndicator - radiobutton - indicator off} unix {
- catch {destroy .m1}
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-12.5 {DrawMenuEntryIndicator - radiobutton - indicator off} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add radiobutton -label foo -indicatoron 0
set tearoff [tk::TearOffMenu .m1 40 40]
- list [catch {update} msg] $msg [destroy .m1]
-} {0 {} {}}
-test unixMenu-12.6 {DrawMenuEntryIndicator - radiobutton - not selected} unix {
- catch {destroy .m1}
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-12.6 {DrawMenuEntryIndicator - radiobutton - not selected} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add radiobutton -label foo
set tearoff [tk::TearOffMenu .m1 40 40]
- list [catch {update} msg] $msg [destroy .m1]
-} {0 {} {}}
-test unixMenu-12.7 {DrawMenuEntryIndicator - radiobutton - selected} unix {
- catch {destroy .m1}
+ list [update] [destroy .m1]
+} -result {{} {}}
+test unixMenu-12.7 {DrawMenuEntryIndicator - radiobutton - selected} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add radiobutton -label foo
.m1 invoke 1
set tearoff [tk::TearOffMenu .m1 40 40]
- list [catch {update} msg] $msg [destroy .m1]
-} {0 {} {}}
+ list [update] [destroy .m1]
+} -result {{} {}}
+
-test unixMenu-13.1 {DrawMenuSeparator - menubar case} unix {
- catch {destroy .m1}
+test unixMenu-13.1 {DrawMenuSeparator - menubar case} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add separator
. configure -menu .m1
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test unixMenu-13.2 {DrawMenuSepartor - normal menu} unix {
- catch {destroy .m1}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-13.2 {DrawMenuSepartor - normal menu} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add separator
set tearoff [tk::TearOffMenu .m1 40 40]
- list [catch {update} msg] $msg [destroy .m1]
-} {0 {} {}}
+ list [update] [destroy .m1]
+} -result {{} {}}
+
-test unixMenu-14.1 {DrawMenuEntryLabel} unix {
- catch {destroy .m1}
+test unixMenu-14.1 {DrawMenuEntryLabel} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label foo
set tearoff [tk::TearOffMenu .m1 40 40]
- list [catch {update} msg] $msg [destroy .m1]
-} {0 {} {}}
+ list [update] [destroy .m1]
+} -result {{} {}}
-test unixMenu-15.1 {DrawMenuUnderline - menubar} unix {
- catch {destroy .m1}
+
+test unixMenu-15.1 {DrawMenuUnderline - menubar} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label foo -underline 0
. configure -menu .m1
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test unixMenu-15.2 {DrawMenuUnderline - no menubar} unix {
- catch {destroy .m1}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-15.2 {DrawMenuUnderline - no menubar} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label foo -underline 0
set tearoff [tk::TearOffMenu .m1 40 40]
- list [catch {update} msg] $msg [destroy .m1]
-} {0 {} {}}
+ list [update] [destroy .m1]
+} -result {{} {}}
+
-test unixMenu-16.1 {TkpPostMenu} unix {
- catch {destroy .m1}
+test unixMenu-16.1 {TkpPostMenu} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label foo
- list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1]
-} {0 {}}
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
-test unixMenu-17.1 {GetMenuSeparatorGeometry} unix {
- catch {destroy .m1}
+
+test unixMenu-17.1 {GetMenuSeparatorGeometry} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add separator
- list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1]
-} {0 {}}
+ tk::TearOffMenu .m1 40 40
+ destroy .m1
+} -returnCodes ok
+
-test unixMenu-18.1 {GetTearoffEntryGeometry} {unix nonUnixUserInteraction} {
- catch {destroy .m1}
+test unixMenu-18.1 {GetTearoffEntryGeometry} -constraints {
+ unix nonUnixUserInteraction
+} -setup {
+ destroy .mb
+} -body {
menubutton .mb -text "test" -menu .mb.m
menu .mb.m
.mb.m add command -label test
pack .mb
raise .
- list [catch {tk::MbPost .mb} msg] $msg [tk::MenuUnpost .mb.m] [destroy .mb]
-} {0 {} {} {}}
+ list [tk::MbPost .mb] [tk::MenuUnpost .mb.m] [destroy .mb]
+} -result {{} {} {}}
+
# Don't know how to reproduce the case where the tkwin has been deleted.
-test unixMenu-19.1 {TkpComputeMenubarGeometry - zero entries} unix {
- catch {destroy .m1}
+
+test unixMenu-19.1 {TkpComputeMenubarGeometry - zero entries} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
. configure -menu .m1
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
# Don't know how to generate one width windows
-test unixMenu-19.2 {TkpComputeMenubarGeometry - one entry} unix {
- catch {destroy .m1}
+test unixMenu-19.2 {TkpComputeMenubarGeometry - one entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add cascade -label File
. configure -menu .m1
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test unixMenu-19.3 {TkpComputeMenubarGeometry - entry with different font} unix {
- catch {destroy .m1}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.3 {TkpComputeMenubarGeometry - entry with different font} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1 -font "Courier 24"
.m1 add cascade -label File -font "Helvetica 18"
. configure -menu .m1
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test unixMenu-19.4 {TkpComputeMenubarGeometry - separator} unix {
- catch {destroy .m1}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.4 {TkpComputeMenubarGeometry - separator} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add separator
. configure -menu .m1
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test unixMenu-19.5 {TkpComputeMenubarGeometry - First entry} unix {
- catch {destroy .m1}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.5 {TkpComputeMenubarGeometry - First entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
.m1 add cascade -label File
. configure -menu .m1
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test unixMenu-19.6 {TkpComputeMenubarGeometry - First entry too wide} unix {
- catch {destroy .m1}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.6 {TkpComputeMenubarGeometry - First entry too wide} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
.m1 add cascade -label File -font "Times 72"
. configure -menu .m1
wm geometry . 10x10
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test unixMenu-19.7 {TkpComputeMenubarGeometry - two entries fit} unix {
- catch {destroy .m1}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.7 {TkpComputeMenubarGeometry - two entries fit} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
.m1 add cascade -label File
.m1 add cascade -label Edit
. configure -menu .m1
wm geometry . 200x200
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test unixMenu-19.8 {TkpComputeMenubarGeometry - two entries; 2nd don't fit} unix {
- catch {destroy .m1}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.8 {TkpComputeMenubarGeometry - two entries; 2nd don't fit} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
.m1 add cascade -label File
.m1 add cascade -label Edit -font "Times 72"
. configure -menu .m1
wm geometry . 100x100
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test unixMenu-19.9 {TkpComputeMenubarGeometry - two entries; 1st dont fit} unix {
- catch {destroy .m1}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.9 {TkpComputeMenubarGeometry - two entries; 1st dont fit} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
.m1 add cascade -label File -font "Times 72"
.m1 add cascade -label Edit
. configure -menu .m1
wm geometry . 100x100
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test unixMenu-19.10 {TkpComputeMenubarGeometry - two entries; neither fit} unix {
- catch {destroy .m1}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.10 {TkpComputeMenubarGeometry - two entries; neither fit} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0 -font "Times 72"
.m1 add cascade -label File
.m1 add cascade -label Edit
. configure -menu .m1
wm geometry . 10x10
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
# ABC notation; capital A means first window fits, small a means it
# does not. capital B menu means second window fist, etc.
-test unixMenu-19.11 {TkpComputeMenubarGeometry - abc} unix {
- catch {destroy .m1}
+test unixMenu-19.11 {TkpComputeMenubarGeometry - abc} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0 -font "Times 72"
.m1 add cascade -label "aaaaa"
.m1 add cascade -label "bbbbb"
.m1 add cascade -label "ccccc"
. configure -menu .m1
wm geometry . 10x10
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test unixMenu-19.12 {TkpComputeMenubarGeometry - abC} unix {
- catch {destroy .m1}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.12 {TkpComputeMenubarGeometry - abC} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
.m1 add cascade -label "aaaaa" -font "Times 72"
.m1 add cascade -label "bbbbb" -font "Times 72"
.m1 add cascade -label "C"
. configure -menu .m1
wm geometry . 10x10
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test unixMenu-19.13 {TkpComputeMenubarGeometry - aBc} unix {
- catch {destroy .m1}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.13 {TkpComputeMenubarGeometry - aBc} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
.m1 add cascade -label "aaaaa" -font "Times 72"
.m1 add cascade -label "B"
.m1 add cascade -label "ccccc" -font "Times 72"
. configure -menu .m1
wm geometry . 10x10
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test unixMenu-19.14 {TkpComputeMenubarGeometry - aBC} unix {
- catch {destroy .m1}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.14 {TkpComputeMenubarGeometry - aBC} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
.m1 add cascade -label "aaaaa" -font "Times 72"
.m1 add cascade -label "B"
.m1 add cascade -label "C"
. configure -menu .m1
wm geometry . 60x10
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test unixMenu-19.15 {TkpComputeMenubarGeometry - Abc} unix {
- catch {destroy .m1}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.15 {TkpComputeMenubarGeometry - Abc} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
.m1 add cascade -label "A"
.m1 add cascade -label "bbbbb" -font "Times 72"
.m1 add cascade -label "ccccc" -font "Times 72"
. configure -menu .m1
wm geometry . 60x10
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test unixMenu-19.16 {TkpComputeMenubarGeometry - AbC} unix {
- catch {destroy .m1}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.16 {TkpComputeMenubarGeometry - AbC} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
.m1 add cascade -label "A"
.m1 add cascade -label "bbbbb" -font "Times 72"
.m1 add cascade -label "C"
. configure -menu .m1
wm geometry . 60x10
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test unixMenu-19.17 {TkpComputeMenubarGeometry - ABc} unix {
- catch {destroy .m1}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.17 {TkpComputeMenubarGeometry - ABc} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
.m1 add cascade -label "A"
.m1 add cascade -label "B"
.m1 add cascade -label "ccccc" -font "Times 72"
. configure -menu .m1
wm geometry . 60x10
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test unixMenu-19.18 {TkpComputeMenubarGeometry - ABC} unix {
- catch {destroy .m1}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.18 {TkpComputeMenubarGeometry - ABC} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
.m1 add cascade -label "A"
.m1 add cascade -label "B"
.m1 add cascade -label "C"
. configure -menu .m1
wm geometry . 100x10
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test unixMenu-19.19 {TkpComputeMenubarGeometry - help menu in first position} unix {
- catch {destroy .m1}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.19 {TkpComputeMenubarGeometry - help menu in first position} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
.m1 add cascade -label Help -menu .m1.help
menu .m1.help -tearoff 0
@@ -486,10 +660,13 @@ test unixMenu-19.19 {TkpComputeMenubarGeometry - help menu in first position} un
menu .m1.edit -tearoff 0
. configure -menu .m1
wm geometry . 100x10
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test unixMenu-19.20 {TkpComputeMenubarGeometry - help menu in middle} unix {
- catch {destroy .m1}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.20 {TkpComputeMenubarGeometry - help menu in middle} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
.m1 add cascade -label Edit -menu .m1.edit
menu .m1.edit -tearoff 0
@@ -499,10 +676,13 @@ test unixMenu-19.20 {TkpComputeMenubarGeometry - help menu in middle} unix {
menu .m1.file -tearoff 0
. configure -menu .m1
wm geometry . 100x10
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test unixMenu-19.21 {TkpComputeMenubarGeometry - help menu in first position} unix {
- catch {destroy .m1}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.21 {TkpComputeMenubarGeometry - help menu in first position} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
.m1 add cascade -label File -menu .m1.file
menu .m1.file -tearoff 0
@@ -512,10 +692,13 @@ test unixMenu-19.21 {TkpComputeMenubarGeometry - help menu in first position} un
menu .m1.help -tearoff 0
. configure -menu .m1
wm geometry . 100x10
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test unixMenu-19.22 {TkpComputeMenubarGeometry - help item fits} unix {
- catch {destroy .m1}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.22 {TkpComputeMenubarGeometry - help item fits} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
.m1 add cascade -label File -menu .m1.file
menu .m1.file -tearoff 0
@@ -523,10 +706,13 @@ test unixMenu-19.22 {TkpComputeMenubarGeometry - help item fits} unix {
menu .m1.help -tearoff 0
. configure -menu .m1
wm geometry . 100x10
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test unixMenu-19.23 {TkpComputeMenubarGeometry - help item does not fit} unix {
- catch {destroy .m1}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.23 {TkpComputeMenubarGeometry - help item does not fit} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
.m1 add cascade -label File -menu .m1.file
menu .m1.file -tearoff 0
@@ -534,215 +720,283 @@ test unixMenu-19.23 {TkpComputeMenubarGeometry - help item does not fit} unix {
menu .m1.help -tearoff 0
. configure -menu .m1
wm geometry . 100x10
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test unixMenu-19.24 {TkpComputeMenubarGeometry - help item only one} unix {
- catch {destroy .m1}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-19.24 {TkpComputeMenubarGeometry - help item only one} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
.m1 add cascade -label Help -menu .m1.help
menu .m1.help -tearoff 0
. configure -menu .m1
wm geometry . 100x10
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+
-test unixMenu-20.1 {DrawTearoffEntry - menubar} unix {
- catch {destroy .m1}
+test unixMenu-20.1 {DrawTearoffEntry - menubar} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add cascade -label File
. configure -menu .m1
- list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 {} {} {}}
-test unixMenu-20.2 {DrawTearoffEntry - non-menubar} {unix nonUnixUserInteraction} {
- catch {destroy .m1}
+ list [update] [. configure -menu ""] [destroy .m1]
+} -result {{} {} {}}
+test unixMenu-20.2 {DrawTearoffEntry - non-menubar} -constraints {
+ unix nonUnixUserInteraction
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label foo
.m1 post 40 40
- list [catch {update} msg] $msg [destroy .m1]
-} {0 {} {}}
+ list [update] [destroy .m1]
+} -result {{} {}}
-test unixMenu-21.1 {TkpInitializeMenuBindings - nothing to do} {} {}
-test unixMenu-22.1 {SetHelpMenu - no menubars} unix {
- catch {destroy .m1}
+test unixMenu-21.1 {TkpInitializeMenuBindings - nothing to do} -constraints unix -body {}
+
+
+test unixMenu-22.1 {SetHelpMenu - no menubars} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
.m1 add cascade -label test -menu .m1.test
- list [catch {menu .m1.test} msg] $msg [destroy .m1]
-} {0 .m1.test {}}
+ list [menu .m1.test] [destroy .m1]
+} -result {.m1.test {}}
# Don't know how to automate missing tkwins
-test unixMenu-22.2 {SetHelpMenu - menubar but no help menu} unix {
- catch {destroy .m1}
+test unixMenu-22.2 {SetHelpMenu - menubar but no help menu} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
. configure -menu .m1
.m1 add cascade -label .m1.file
- list [catch {menu .m1.file} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 .m1.file {} {}}
-test unixMenu-22.3 {SetHelpMenu - menubar with help menu} unix {
- catch {destroy .m1}
+ list [menu .m1.file] [. configure -menu ""] [destroy .m1]
+} -result {.m1.file {} {}}
+test unixMenu-22.3 {SetHelpMenu - menubar with help menu} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
. configure -menu .m1
.m1 add cascade -label .m1.help
- list [catch {menu .m1.help} msg] $msg [. configure -menu ""] [destroy .m1]
-} {0 .m1.help {} {}}
-test unixMenu-22.4 {SetHelpMenu - multiple menubars with same help menu} unix {
- catch {destroy .m1}
- catch {destroy .t2}
+ list [menu .m1.help] [. configure -menu ""] [destroy .m1]
+} -result {.m1.help {} {}}
+test unixMenu-22.4 {SetHelpMenu - multiple menubars with same help menu} -constraints {
+ unix
+} -setup {
+ destroy .m1 .t2
+} -body {
toplevel .t2
wm geometry .t2 +40+40
menu .m1 -tearoff 0
. configure -menu .m1
.t2 configure -menu .m1
.m1 add cascade -label .m1.help
- list [catch {menu .m1.help} msg] $msg [. configure -menu ""] [destroy .m1] [destroy .t2]
-} {0 .m1.help {} {} {}}
+ list [menu .m1.help] [. configure -menu ""] [destroy .m1] [destroy .t2]
+} -result {.m1.help {} {} {}}
+
-test unixMenu-23.1 {TkpDrawMenuEntry - gc for active and not strict motif} unix {
- catch {destroy .m1}
+test unixMenu-23.1 {TkpDrawMenuEntry - gc for active and not strict motif} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label foo
set tearoff [tk::TearOffMenu .m1 40 40]
.m1 entryconfigure 1 -state active
list [update] [destroy .m1]
-} {{} {}}
-test unixMenu-23.2 {TkpDrawMenuEntry - gc for active menu item with its own gc} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-23.2 {TkpDrawMenuEntry - gc for active menu item with its own gc} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label foo -activeforeground red
set tearoff [tk::TearOffMenu .m1 40 40]
.m1 entryconfigure 1 -state active
list [update] [destroy .m1]
-} {{} {}}
-test unixMenu-23.3 {TkpDrawMenuEntry - gc for active and strict motif} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-23.3 {TkpDrawMenuEntry - gc for active and strict motif} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
set tk_strictMotif 1
.m1 add command -label foo
set tearoff [tk::TearOffMenu .m1 40 40]
.m1 entryconfigure 1 -state active
list [update] [destroy .m1] [set tk_strictMotif 0]
-} {{} {} 0}
-test unixMenu-23.4 {TkpDrawMenuEntry - gc for disabled with disabledfg and custom entry} unix {
- catch {destroy .m1}
+} -result {{} {} 0}
+test unixMenu-23.4 {TkpDrawMenuEntry - gc for disabled with disabledfg and custom entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1 -disabledforeground blue
.m1 add command -label foo -state disabled -background red
set tearoff [tk::TearOffMenu .m1 40 40]
list [update] [destroy .m1]
-} {{} {}}
-test unixMenu-23.5 {TkpDrawMenuEntry - gc for disabled with disabledFg} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-23.5 {TkpDrawMenuEntry - gc for disabled with disabledFg} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1 -disabledforeground blue
.m1 add command -label foo -state disabled
set tearoff [tk::TearOffMenu .m1 40 40]
list [update] [destroy .m1]
-} {{} {}}
-test unixMenu-23.6 {TkpDrawMenuEntry - gc for disabled - no disabledFg} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-23.6 {TkpDrawMenuEntry - gc for disabled - no disabledFg} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1 -disabledforeground ""
.m1 add command -label foo -state disabled
set tearoff [tk::TearOffMenu .m1 40 40]
list [update] [destroy .m1]
-} {{} {}}
-test unixMenu-23.7 {TkpDrawMenuEntry - gc for normal - custom entry} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-23.7 {TkpDrawMenuEntry - gc for normal - custom entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label foo -foreground red
set tearoff [tk::TearOffMenu .m1 40 40]
list [update] [destroy .m1]
-} {{} {}}
-test unixMenu-23.8 {TkpDrawMenuEntry - gc for normal} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-23.8 {TkpDrawMenuEntry - gc for normal} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label foo
set tearoff [tk::TearOffMenu .m1 40 40]
list [update] [destroy .m1]
-} {{} {}}
-test unixMenu-23.9 {TkpDrawMenuEntry - gc for indicator - custom entry} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-23.9 {TkpDrawMenuEntry - gc for indicator - custom entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add checkbutton -label foo -selectcolor orange
.m1 invoke 1
set tearoff [tk::TearOffMenu .m1 40 40]
list [update] [destroy .m1]
-} {{} {}}
-test unixMenu-23.10 {TkpDrawMenuEntry - gc for indicator} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-23.10 {TkpDrawMenuEntry - gc for indicator} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add checkbutton -label foo
.m1 invoke 1
set tearoff [tk::TearOffMenu .m1 40 40]
list [update] [destroy .m1]
-} {{} {}}
-test unixMenu-23.11 {TkpDrawMenuEntry - border - custom entry} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-23.11 {TkpDrawMenuEntry - border - custom entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label foo -activebackground green
set tearoff [tk::TearOffMenu .m1 40 40]
.m1 entryconfigure 1 -state active
list [update] [destroy .m1]
-} {{} {}}
-test unixMenu-23.12 {TkpDrawMenuEntry - border} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-23.12 {TkpDrawMenuEntry - border} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label foo
set tearoff [tk::TearOffMenu .m1 40 40]
.m1 entryconfigure 1 -state active
list [update] [destroy .m1]
-} {{} {}}
-test unixMenu-23.13 {TkpDrawMenuEntry - active border - strict motif} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-23.13 {TkpDrawMenuEntry - active border - strict motif} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
set tk_strictMotif 1
menu .m1
.m1 add command -label foo
set tearoff [tk::TearOffMenu .m1 40 40]
.m1 entryconfigure 1 -state active
list [update] [destroy .m1] [set tk_strictMotif 0]
-} {{} {} 0}
-test unixMenu-23.14 {TkpDrawMenuEntry - active border - custom entry} unix {
- catch {destroy .m1}
+} -result {{} {} 0}
+test unixMenu-23.14 {TkpDrawMenuEntry - active border - custom entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label foo -activeforeground yellow
set tearoff [tk::TearOffMenu .m1 40 40]
.m1 entryconfigure 1 -state active
list [update] [destroy .m1]
-} {{} {}}
-test unixMenu-23.15 {TkpDrawMenuEntry - active border} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-23.15 {TkpDrawMenuEntry - active border} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label foo
set tearoff [tk::TearOffMenu .m1 40 40]
.m1 entryconfigure 1 -state active
list [update] [destroy .m1]
-} {{} {}}
-test unixMenu-23.16 {TkpDrawMenuEntry - font - custom entry} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-23.16 {TkpDrawMenuEntry - font - custom entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label foo -font "Helvectica 72"
set tearoff [tk::TearOffMenu .m1 40 40]
list [update] [destroy .m1]
-} {{} {}}
-test unixMenu-23.17 {TkpDrawMenuEntry - font} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-23.17 {TkpDrawMenuEntry - font} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1 -font "Courier 72"
.m1 add command -label foo
set tearoff [tk::TearOffMenu .m1 40 40]
list [update] [destroy .m1]
-} {{} {}}
-test unixMenu-23.18 {TkpDrawMenuEntry - separator} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-23.18 {TkpDrawMenuEntry - separator} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add separator
set tearoff [tk::TearOffMenu .m1 40 40]
list [update] [destroy .m1]
-} {{} {}}
-test unixMenu-23.19 {TkpDrawMenuEntry - standard} unix {
- catch {destroy .mb}
+} -result {{} {}}
+test unixMenu-23.19 {TkpDrawMenuEntry - standard} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label foo
set tearoff [tk::TearOffMenu .m1 40 40]
list [update] [destroy .m1]
-} {{} {}}
-test unixMenu-23.20 {TkpDrawMenuEntry - disabled cascade item} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-23.20 {TkpDrawMenuEntry - disabled cascade item} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add cascade -label File -menu .m1.file
menu .m1.file
@@ -750,140 +1004,192 @@ test unixMenu-23.20 {TkpDrawMenuEntry - disabled cascade item} unix {
.m1 entryconfigure File -state disabled
set tearoff [tk::TearOffMenu .m1 40 40]
list [update] [destroy .m1]
-} {{} {}}
-test unixMenu-23.21 {TkpDrawMenuEntry - indicator} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-23.21 {TkpDrawMenuEntry - indicator} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add checkbutton -label Foo
.m1 invoke Foo
set tearoff [tk::TearOffMenu .m1 40 40]
list [update] [destroy .m1]
-} {{} {}}
-test unixMenu-23.22 {TkpDrawMenuEntry - hide margin} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-23.22 {TkpDrawMenuEntry - hide margin} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add checkbutton -label Foo -hidemargin 1
.m1 invoke Foo
set tearoff [tk::TearOffMenu .m1 40 40]
list [update] [destroy .m1]
-} {{} {}}
+} -result {{} {}}
-test unixMenu-24.1 {GetMenuLabelGeometry - image} {testImageType unix} {
- catch {destroy .m1}
+
+test unixMenu-24.1 {GetMenuLabelGeometry - image} -constraints {
+ testImageType unix
+} -setup {
+ destroy .m1
catch {image delete image1}
+} -body {
menu .m1
image create test image1
.m1 add command -image image1
list [update idletasks] [destroy .m1] [image delete image1]
-} {{} {} {}}
-test unixMenu-24.2 {GetMenuLabelGeometry - bitmap} unix {
- catch {destroy .m1}
+} -result {{} {} {}}
+test unixMenu-24.2 {GetMenuLabelGeometry - bitmap} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -bitmap questhead
list [update idletasks] [destroy .m1]
-} {{} {}}
-test unixMenu-24.3 {GetMenuLabelGeometry - no text} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-24.3 {GetMenuLabelGeometry - no text} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command
list [update idletasks] [destroy .m1]
-} {{} {}}
-test unixMenu-24.4 {GetMenuLabelGeometry - text} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-24.4 {GetMenuLabelGeometry - text} -constraints unix -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "This is a test."
list [update idletasks] [destroy .m1]
-} {{} {}}
+} -result {{} {}}
+
-test unixMenu-25.1 {TkpComputeStandardMenuGeometry - no entries} unix {
- catch {destroy .m1}
+test unixMenu-25.1 {TkpComputeStandardMenuGeometry - no entries} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
list [update idletasks] [destroy .m1]
-} {{} {}}
-test unixMenu-25.2 {TkpComputeStandardMenuGeometry - one entry} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-25.2 {TkpComputeStandardMenuGeometry - one entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "one"
list [update idletasks] [destroy .m1]
-} {{} {}}
-test unixMenu-25.3 {TkpComputeStandardMenuGeometry - more than one entry} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-25.3 {TkpComputeStandardMenuGeometry - more than one entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "one"
.m1 add command -label "two"
list [update idletasks] [destroy .m1]
-} {{} {}}
-test unixMenu-25.4 {TkpComputeStandardMenuGeometry - separator} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-25.4 {TkpComputeStandardMenuGeometry - separator} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add separator
list [update idletasks] [destroy .m1]
-} {{} {}}
-test unixMenu-25.5 {TkpComputeStandardMenuGeometry - tearoff entry} {unix nonUnixUserInteraction} {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-25.5 {TkpComputeStandardMenuGeometry - tearoff entry} -constraints {
+ unix nonUnixUserInteraction
+} -setup {
+ destroy .mb
+} -body {
menubutton .mb -text "test" -menu .mb.m
menu .mb.m
.mb.m add command -label test
pack .mb
catch {tk::MbPost .mb}
list [update] [tk::MenuUnpost .mb.m] [destroy .mb]
-} {{} {} {}}
-test unixMenu-25.6 {TkpComputeStandardMenuGeometry - standard label geometry} unix {
- catch {destroy .m1}
+} -result {{} {} {}}
+test unixMenu-25.6 {TkpComputeStandardMenuGeometry - standard label geometry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "test"
list [update idletasks] [destroy .m1]
-} {{} {}}
-test unixMenu-25.7 {TkpComputeStandardMenuGeometry - different font for entry} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-25.7 {TkpComputeStandardMenuGeometry - different font for entry} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1 -font "Helvetica 12"
.m1 add command -label "test" -font "Courier 12"
list [update idletasks] [destroy .m1]
-} {{} {}}
-test unixMenu-25.8 {TkpComputeStandardMenuGeometry - second entry larger} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-25.8 {TkpComputeStandardMenuGeometry - second entry larger} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "test"
.m1 add command -label "test test"
list [update idletasks] [destroy .m1]
-} {{} {}}
-test unixMenu-25.9 {TkpComputeStandardMenuGeometry - first entry larger} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-25.9 {TkpComputeStandardMenuGeometry - first entry larger} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "test test"
.m1 add command -label "test"
list [update idletasks] [destroy .m1]
-} {{} {}}
-test unixMenu-25.10 {TkpComputeStandardMenuGeometry - accelerator} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-25.10 {TkpComputeStandardMenuGeometry - accelerator} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "test" -accel "Ctrl+S"
list [update idletasks] [destroy .m1]
-} {{} {}}
-test unixMenu-25.11 {TkpComputeStandardMenuGeometry - second accel larger} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-25.11 {TkpComputeStandardMenuGeometry - second accel larger} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "test" -accel "1"
.m1 add command -label "test" -accel "1 1"
list [update idletasks] [destroy .m1]
-} {{} {}}
-test unixMenu-25.12 {TkpComputeStandardMenuGeometry - second accel smaller} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-25.12 {TkpComputeStandardMenuGeometry - second accel smaller} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label "test" -accel "1 1"
.m1 add command -label "test" -accel "1"
list [update idletasks] [destroy .m1]
-} {{} {}}
-test unixMenu-25.13 {TkpComputeStandardMenuGeometry - indicator} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-25.13 {TkpComputeStandardMenuGeometry - indicator} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add checkbutton -label test
.m1 invoke 1
list [update idletasks] [destroy .m1]
-} {{} {}}
-test unixMenu-25.14 {TkpComputeStandardMenuGeometry - second indicator less or equal } {unix testImageType} {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-25.14 {TkpComputeStandardMenuGeometry - second indicator less or equal } -constraints {
+ unix testImageType
+} -setup {
+ destroy .m1
catch {image delete image1}
+} -body {
image create test image1
menu .m1
.m1 add checkbutton -image image1
@@ -891,10 +1197,13 @@ test unixMenu-25.14 {TkpComputeStandardMenuGeometry - second indicator less or e
.m1 add checkbutton -label test
.m1 invoke 2
list [update idletasks] [destroy .m1] [image delete image1]
-} {{} {} {}}
-test unixMenu-25.15 {TkpComputeStandardMenuGeometry - second indicator larger } {unix testImageType} {
- catch {destroy .m1}
+} -result {{} {} {}}
+test unixMenu-25.15 {TkpComputeStandardMenuGeometry - second indicator larger } -constraints {
+ unix testImageType
+} -setup {
+ destroy .m1
catch {image delete image1}
+} -body {
image create test image1
menu .m1
.m1 add checkbutton -image image1
@@ -902,30 +1211,42 @@ test unixMenu-25.15 {TkpComputeStandardMenuGeometry - second indicator larger }
.m1 add checkbutton -label test
.m1 invoke 2
list [update idletasks] [destroy .m1] [image delete image1]
-} {{} {} {}}
-test unixMenu-25.16 {TkpComputeStandardMenuGeometry - zero sized menus} unix {
- catch {destroy .m1}
+} -result {{} {} {}}
+test unixMenu-25.16 {TkpComputeStandardMenuGeometry - zero sized menus} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
list [update idletasks] [destroy .m1]
-} {{} {}}
-test unixMenu-25.17 {TkpComputeStandardMenuGeometry - first column bigger} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-25.17 {TkpComputeStandardMenuGeometry - first column bigger} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1
.m1 add command -label one
.m1 add command -label two
.m1 add command -label three -columnbreak 1
list [update idletasks] [destroy .m1]
-} {{} {}}
-test unixMenu-25.18 {TkpComputeStandardMenuGeometry - second column bigger} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-25.18 {TkpComputeStandardMenuGeometry - second column bigger} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
.m1 add command -label one
.m1 add command -label two -columnbreak 1
.m1 add command -label three
list [update idletasks] [destroy .m1]
-} {{} {}}
-test unixMenu-25.19 {TkpComputeStandardMenuGeometry - three columns} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-25.19 {TkpComputeStandardMenuGeometry - three columns} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
.m1 add command -label one
.m1 add command -label two -columnbreak 1
@@ -934,17 +1255,23 @@ test unixMenu-25.19 {TkpComputeStandardMenuGeometry - three columns} unix {
.m1 add command -label five -columnbreak 1
.m1 add command -label six
list [update idletasks] [destroy .m1]
-} {{} {}}
-test unixMenu-25.20 {TkpComputeStandardMenuGeometry - hide margin} unix {
- catch {destroy .m1}
+} -result {{} {}}
+test unixMenu-25.20 {TkpComputeStandardMenuGeometry - hide margin} -constraints {
+ unix
+} -setup {
+ destroy .m1
+} -body {
menu .m1 -tearoff 0
.m1 add checkbutton -label one -hidemargin 1
list [update idletasks] [destroy .m1]
-} {{} {}}
+} -result {{} {}}
+
+
+test unixMenu-26.1 {TkpMenuInit - nothing to do} -constraints unix -body {}
+
-test unixMenu-26.1 {TkpMenuInit - nothing to do} {} {}
# cleanup
deleteWindows
cleanupTests
-return
+return \ No newline at end of file