diff options
| -rw-r--r-- | ChangeLog | 12 | ||||
| -rw-r--r-- | tests/option.test | 505 | ||||
| -rw-r--r-- | tests/place.test | 437 | ||||
| -rw-r--r-- | tests/scale.test | 1498 | ||||
| -rw-r--r-- | tests/select.test | 595 | ||||
| -rw-r--r-- | tests/textBTree.test | 1089 | ||||
| -rw-r--r-- | tests/textImage.test | 690 | ||||
| -rw-r--r-- | tests/textMark.test | 347 | ||||
| -rw-r--r-- | tests/textTag.test | 1663 | ||||
| -rw-r--r-- | tests/unixMenu.test | 1183 |
10 files changed, 5260 insertions, 2759 deletions
@@ -1,3 +1,15 @@ +2008-08-28 Ania Pawelczyk <aniap@users.sourceforge.net> + + * tests/option.test: Update to tcltest2 + * tests/place.test: + * tests/scale.test: + * tests/select.test: + * tests/textBTree.test: + * tests/textImage.test: + * tests/textMark.test: + * tests/textTag.test: + * tests/unixMenu.test: + 2008-08-25 Todd M. Helfter <tmh@users.sourceforge.net> * library/menu.tcl: fix typo from [Bug 1023955] 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 |