diff options
Diffstat (limited to 'tk8.6/tests/config.test')
| -rw-r--r-- | tk8.6/tests/config.test | 1929 |
1 files changed, 1929 insertions, 0 deletions
diff --git a/tk8.6/tests/config.test b/tk8.6/tests/config.test new file mode 100644 index 0000000..a0c1921 --- /dev/null +++ b/tk8.6/tests/config.test @@ -0,0 +1,1929 @@ +# This file is a Tcl script to test the procedures in tkConfig.c, +# which comprise the new new option configuration system. It is +# organized in the standard "white-box" fashion for Tcl tests. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. + +package require tcltest 2.2 +namespace import ::tcltest::* +eval tcltest::configure $argv +tcltest::loadTestedCommands + +proc killTables {} { + # Note: it's important to delete chain2 before chain1, because + # chain2 depends on chain1. If chain1 is deleted first, the + # delete of chain2 will crash. + deleteWindows + foreach t {alltypes chain3 chain2 chain1 configerror internal + new notenoughparams twowindows} { + while {[testobjconfig info $t] != ""} { + testobjconfig delete $t + } + } +} + + +option clear +deleteWindows +if {[testConstraint testobjconfig]} { + killTables +} + +test config-1.1 {Tk_CreateOptionTable - reference counts} -constraints { + testobjconfig +} -body { + set x {} + testobjconfig alltypes .a + lappend x [testobjconfig info alltypes] + testobjconfig alltypes .b + lappend x [testobjconfig info alltypes] + set x +} -cleanup { + killTables +} -result {{1 16 -boolean} {2 16 -boolean}} +test config-1.2 {Tk_CreateOptionTable - synonym initialization} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .a -synonym green + .a cget -color +} -cleanup { + killTables +} -result {green} +test config-1.3 {Tk_CreateOptionTable - option database initialization} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .a + option add *b.string different + testobjconfig alltypes .b + list [.a cget -string] [.b cget -string] +} -cleanup { + killTables + option clear +} -result {foo different} +test config-1.4 {Tk_CreateOptionTable - option database initialization} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .a + option add *b.String bar + testobjconfig alltypes .b + list [.a cget -string] [.b cget -string] +} -cleanup { + killTables + option clear +} -result {foo bar} +test config-1.5 {Tk_CreateOptionTable - default initialization} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .a + .a cget -relief +} -cleanup { + killTables +} -result {raised} +test config-1.6 {Tk_CreateOptionTable - chained tables} -constraints { + testobjconfig +} -body { + testobjconfig chain1 .a + testobjconfig chain2 .b + testobjconfig info chain2 +} -cleanup { + killTables +} -result {1 4 -three 2 2 -one} +test config-1.7 {Tk_CreateOptionTable - chained tables} -constraints { + testobjconfig +} -body { + testobjconfig chain2 .b + testobjconfig chain1 .a + testobjconfig info chain2 +} -cleanup { + killTables +} -result {1 4 -three 2 2 -one} +test config-1.8 {Tk_CreateOptionTable - chained tables} -constraints { + testobjconfig +} -body { + testobjconfig chain1 .a + testobjconfig chain2 .b + .a cget -four +} -cleanup { + killTables +} -returnCodes error -result {unknown option "-four"} +test config-1.9 {Tk_CreateOptionTable - chained tables} -constraints { + testobjconfig +} -body { + testobjconfig chain1 .a + testobjconfig chain2 .b + catch {.a cget -four} + list [.a cget -one] [.b cget -four] [.b cget -one] +} -cleanup { + killTables +} -result {one four one} + + +test config-2.1 {Tk_DeleteOptionTable - reference counts} -constraints { + testobjconfig +} -body { + set x {} + testobjconfig chain1 .a + testobjconfig chain2 .b + testobjconfig chain3 .c + deleteWindows + testobjconfig delete chain3 + lappend x [testobjconfig info chain2] [testobjconfig info chain1] + testobjconfig delete chain2 + lappend x [testobjconfig info chain2] [testobjconfig info chain1] +} -cleanup { + killTables +} -result {{3 4 -three 2 2 -one} {2 2 -one} {} {2 2 -one}} + +# No tests for DestroyOptionHashTable; couldn't figure out how to test. + +test config-3.1 {Tk_InitOptions - priority of chained tables} -constraints { + testobjconfig +} -body { + testobjconfig chain1 .a + testobjconfig chain2 .b + list [.a cget -two] [.b cget -two] +} -cleanup { + killTables +} -result {two {two and a half}} +test config-3.2 {Tk_InitOptions - initialize from database} -constraints { + testobjconfig +} -body { + option add *a.color blue + testobjconfig alltypes .a + list [.a cget -color] +} -cleanup { + killTables + option clear +} -result {blue} +test config-3.3 {Tk_InitOptions - initialize from database} -constraints { + testobjconfig +} -body { + option add *a.justify bogus + testobjconfig alltypes .a + list [.a cget -justify] +} -cleanup { + killTables + option clear +} -result {left} +test config-3.4 {Tk_InitOptions - initialize from widget class} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .a + list [.a cget -color] +} -cleanup { + killTables +} -result {red} +test config-3.5 {Tk_InitOptions - no initial value} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .a + .a cget -anchor +} -cleanup { + killTables +} -result {} +test config-3.6 {Tk_InitOptions - bad initial value} -constraints { + testobjconfig +} -body { + option add *a.color non-existent + testobjconfig alltypes .a +} -cleanup { + killTables + option clear +} -returnCodes error -result {unknown color name "non-existent"} +test config-3.7 {Tk_InitOptions - bad initial value} -constraints { + testobjconfig +} -body { + option add *a.color non-existent + catch {testobjconfig alltypes .a} + return $errorInfo +} -cleanup { + killTables + option clear +} -result {unknown color name "non-existent" + (database entry for "-color" in widget ".a") + invoked from within +"testobjconfig alltypes .a"} + +test config-3.8 {Tk_InitOptions - bad initial value} -constraints { + testobjconfig +} -body { + testobjconfig configerror +} -returnCodes error -result {expected integer but got "bogus"} +test config-3.9 {Tk_InitOptions - bad initial value} -constraints { + testobjconfig +} -body { + catch {testobjconfig configerror} + return $errorInfo +} -result {expected integer but got "bogus" + (default value for "-int") + invoked from within +"testobjconfig configerror"} + +test config-4.1 {DoObjConfig - boolean} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -boolean 0 +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.2 {DoObjConfig - boolean} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -boolean 0 + .foo cget -boolean +} -cleanup { + killTables +} -returnCodes ok -result {0} +test config-4.3 {DoObjConfig - boolean} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -boolean 0 + .foo cget -boolean + rename .foo {} +} -cleanup { + killTables +} -returnCodes ok +test config-4.4 {DoObjConfig - boolean} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -boolean 1 +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.5 {DoObjConfig - boolean} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -boolean 1 + .foo cget -boolean +} -cleanup { + killTables +} -returnCodes ok -result {1} +test config-4.6 {DoObjConfig - boolean} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -boolean 1 + .foo cget -boolean + rename .foo {} +} -cleanup { + killTables +} -returnCodes ok +test config-4.7 {DoObjConfig - invalid boolean} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -boolean {} +} -cleanup { + killTables +} -returnCodes error -result {expected boolean value but got ""} +test config-4.8 {DoObjConfig - boolean internal value} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { + testobjconfig internal .foo -boolean 0 + .foo cget -boolean +} -cleanup { + killTables +} -result {0} + +test config-4.9 {DoObjConfig - integer} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -integer 3 +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.10 {DoObjConfig - integer} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -integer 3 + .foo cget -integer +} -cleanup { + killTables +} -returnCodes ok -result {3} +test config-4.11 {DoObjConfig - integer} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -integer 3 + .foo cget -integer + rename .foo {} +} -cleanup { + killTables +} -returnCodes ok +test config-4.12 {DoObjConfig - invalid integer} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -integer bar +} -cleanup { + killTables +} -cleanup { + killTables +} -returnCodes error -result {expected integer but got "bar"} +test config-4.13 {DoObjConfig - integer internal value} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { + testobjconfig internal .foo -integer 421 + .foo cget -integer +} -cleanup { + killTables +} -result {421} + +test config-4.14 {DoObjConfig - double} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -double 3.14 +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.15 {DoObjConfig - double} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -double 3.14 + .foo cget -double +} -cleanup { + killTables +} -returnCodes ok -result {3.14} +test config-4.16 {DoObjConfig - double} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -double 3.14 + .foo cget -double + rename .foo {} +} -cleanup { + killTables +} -returnCodes ok +test config-4.17 {DoObjConfig - invalid double} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -double bar +} -cleanup { + killTables +} -returnCodes error -result {expected floating-point number but got "bar"} +test config-4.18 {DoObjConfig - double internal value} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { + testobjconfig internal .foo -double 62.75 + .foo cget -double +} -cleanup { + killTables +} -result {62.75} + +test config-4.19 {DoObjConfig - string} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -string test +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.20 {DoObjConfig - string} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -string test + .foo cget -string +} -cleanup { + killTables +} -returnCodes ok -result {test} +test config-4.21 {DoObjConfig - string} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -string test + .foo cget -string + rename .foo {} +} -cleanup { + killTables +} -returnCodes ok +test config-4.22 {DoObjConfig - null string} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -string {} +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.23 {DoObjConfig - null string} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -string {} + .foo cget -string +} -cleanup { + killTables +} -returnCodes ok -result {} +test config-4.24 {DoObjConfig - null string} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -string {} + .foo cget -string + rename .foo {} +} -cleanup { + killTables +} -returnCodes ok + +test config-4.25 {DoObjConfig - string internal value} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { + testobjconfig internal .foo -string "this is a test" + .foo cget -string +} -cleanup { + killTables +} -result {this is a test} + +test config-4.26 {DoObjConfig - string table} -constraints testobjconfig -body { + testobjconfig alltypes .foo -stringtable two +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.27 {DoObjConfig - string table} -constraints testobjconfig -body { + testobjconfig alltypes .foo -stringtable two + .foo cget -stringtable +} -cleanup { + killTables +} -returnCodes ok -result {two} +test config-4.28 {DoObjConfig - string table} -constraints testobjconfig -body { + testobjconfig alltypes .foo -stringtable two + .foo cget -stringtable + rename .foo {} +} -cleanup { + killTables +} -returnCodes ok +test config-4.29 {DoObjConfig - invalid string table} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -stringtable foo +} -cleanup { + killTables +} -returnCodes error -result {bad stringtable "foo": must be one, two, three, or four} + +test config-4.30 {DoObjConfig - new string table} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -stringtable two + .foo configure -stringtable three +} -cleanup { + killTables +} -returnCodes ok -result {16} +test config-4.31 {DoObjConfig - new string table} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -stringtable two + .foo configure -stringtable three + .foo cget -stringtable +} -cleanup { + killTables +} -returnCodes ok -result {three} +test config-4.32 {DoObjConfig - new string table} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -stringtable two + .foo configure -stringtable three + .foo cget -stringtable + rename .foo {} +} -cleanup { + killTables +} -returnCodes ok +test config-4.33 {DoObjConfig - stringtable internal value} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { + testobjconfig internal .foo -stringtable "four" + .foo cget -stringtable +} -cleanup { + killTables +} -result {four} + +test config-4.34 {DoObjConfig - color} -constraints testobjconfig -body { + testobjconfig alltypes .foo -color blue +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.35 {DoObjConfig - color} -constraints testobjconfig -body { + testobjconfig alltypes .foo -color blue + .foo cget -color +} -cleanup { + killTables +} -returnCodes ok -result {blue} +test config-4.36 {DoObjConfig - color} -constraints testobjconfig -body { + testobjconfig alltypes .foo -color blue + .foo cget -color + rename .foo {} +} -cleanup { + killTables +} -returnCodes ok +test config-4.37 {DoObjConfig - invalid color} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -color xxx +} -cleanup { + killTables +} -returnCodes error -result {unknown color name "xxx"} +test config-4.38 {DoObjConfig - color internal value} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { + testobjconfig internal .foo -color purple + .foo cget -color +} -cleanup { + killTables +} -result {purple} + +test config-4.39 {DoObjConfig - null color} -constraints testobjconfig -body { + testobjconfig alltypes .foo -color {} +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.40 {DoObjConfig - null color} -constraints testobjconfig -body { + testobjconfig alltypes .foo -color {} + .foo cget -color +} -cleanup { + killTables +} -returnCodes ok -result {} +test config-4.41 {DoObjConfig - null color} -constraints testobjconfig -body { + testobjconfig alltypes .foo -color {} + .foo cget -color + rename .foo {} +} -cleanup { + killTables +} -returnCodes ok +test config-4.42 {DoObjConfig - getting rid of old color} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -color #333333 + .foo configure -color #444444 +} -cleanup { + killTables +} -returnCodes ok -result {32} +test config-4.43 {DoObjConfig - getting rid of old color} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -color #333333 + .foo configure -color #444444 + .foo cget -color +} -cleanup { + killTables +} -returnCodes ok -result {#444444} +test config-4.44 {DoObjConfig - getting rid of old color} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -color #333333 + .foo configure -color #444444 + .foo cget -color + rename .foo {} +} -cleanup { + killTables +} -returnCodes ok + +test config-4.45 {DoObjConfig - font} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -font {Helvetica 72} +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.46 {DoObjConfig - font} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -font {Helvetica 72} + .foo cget -font +} -cleanup { + killTables +} -returnCodes ok -result {Helvetica 72} +test config-4.47 {DoObjConfig - new font} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -font {Courier 12} + .foo configure -font {Helvetica 72} +} -cleanup { + killTables +} -returnCodes ok -result {64} +test config-4.48 {DoObjConfig - new font} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -font {Courier 12} + .foo configure -font {Helvetica 72} + .foo cget -font +} -cleanup { + killTables +} -returnCodes ok -result {Helvetica 72} +test config-4.49 {DoObjConfig - invalid font} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -font {Helvetica 12 foo} +} -cleanup { + killTables +} -returnCodes error -result {unknown font style "foo"} +test config-4.50 {DoObjConfig - null font} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -font {} +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.51 {DoObjConfig - null font} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -font {} + .foo cget -font +} -cleanup { + killTables +} -returnCodes ok -result {} +test config-4.52 {DoObjConfig - font internal value} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { + testobjconfig internal .foo -font {Times 16} + .foo cget -font +} -cleanup { + killTables +} -result {Times 16} + +test config-4.53 {DoObjConfig - bitmap} -constraints testobjconfig -body { + testobjconfig alltypes .foo -bitmap gray75 +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.54 {DoObjConfig - bitmap} -constraints testobjconfig -body { + testobjconfig alltypes .foo -bitmap gray75 + .foo cget -bitmap +} -cleanup { + killTables +} -returnCodes ok -result {gray75} +test config-4.55 {DoObjConfig - new bitmap} -constraints testobjconfig -body { + testobjconfig alltypes .foo -bitmap gray75 + .foo configure -bitmap gray50 +} -cleanup { + killTables +} -returnCodes ok -result {128} +test config-4.56 {DoObjConfig - new bitmap} -constraints testobjconfig -body { + testobjconfig alltypes .foo -bitmap gray75 + .foo configure -bitmap gray50 + .foo cget -bitmap +} -cleanup { + killTables +} -returnCodes ok -result {gray50} +test config-4.57 {DoObjConfig - invalid bitmap} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -bitmap foo +} -cleanup { + killTables +} -returnCodes error -result {bitmap "foo" not defined} +test config-4.58 {DoObjConfig - null bitmap} -constraints testobjconfig -body { + testobjconfig alltypes .foo -bitmap {} +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.59 {DoObjConfig - null bitmap} -constraints testobjconfig -body { + testobjconfig alltypes .foo -bitmap {} + .foo cget -bitmap +} -cleanup { + killTables +} -returnCodes ok -result {} +test config-4.60 {DoObjConfig - bitmap internal value} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { + testobjconfig internal .foo -bitmap gray25 + .foo cget -bitmap +} -cleanup { + killTables +} -result {gray25} + +test config-4.61 {DoObjConfig - border} -constraints testobjconfig -body { + testobjconfig alltypes .foo -border green +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.62 {DoObjConfig - border} -constraints testobjconfig -body { + testobjconfig alltypes .foo -border green + .foo cget -border +} -cleanup { + killTables +} -returnCodes ok -result {green} +test config-4.63 {DoObjConfig - invalid border} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -border xxx +} -cleanup { + killTables +} -returnCodes error -result {unknown color name "xxx"} +test config-4.64 {DoObjConfig - null border} -constraints testobjconfig -body { + testobjconfig alltypes .foo -border {} +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.65 {DoObjConfig - null border} -constraints testobjconfig -body { + testobjconfig alltypes .foo -border {} + .foo cget -border +} -cleanup { + killTables +} -returnCodes ok -result {} +test config-4.66 {DoObjConfig - border internal value} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { + testobjconfig internal .foo -border #123456 + .foo cget -border +} -cleanup { + killTables +} -result {#123456} +test config-4.67 {DoObjConfig - getting rid of old border} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -border #333333 + .foo configure -border #444444 +} -cleanup { + killTables +} -returnCodes ok -result {256} +test config-4.68 {DoObjConfig - getting rid of old border} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -border #333333 + .foo configure -border #444444 + .foo cget -border +} -cleanup { + killTables +} -returnCodes ok -result {#444444} + +test config-4.69 {DoObjConfig - relief} -constraints testobjconfig -body { + testobjconfig alltypes .foo -relief flat +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.70 {DoObjConfig - relief} -constraints testobjconfig -body { + testobjconfig alltypes .foo -relief flat + .foo cget -relief +} -cleanup { + killTables +} -returnCodes ok -result {flat} +test config-4.71 {DoObjConfig - invalid relief} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -relief foo +} -cleanup { + killTables +} -returnCodes error -result {bad relief "foo": must be flat, groove, raised, ridge, solid, or sunken} +test config-4.72 {DoObjConfig - relief internal value} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig internal .foo -relief ridge + .foo cget -relief +} -cleanup { + killTables +} -result {ridge} +test config-4.73 {DoObjConfig - new relief} -constraints testobjconfig -body { + testobjconfig alltypes .foo -relief raised + .foo configure -relief flat +} -cleanup { + killTables +} -returnCodes ok -result {512} +test config-4.74 {DoObjConfig - new relief} -constraints testobjconfig -body { + testobjconfig alltypes .foo -relief raised + .foo configure -relief flat + .foo cget -relief +} -cleanup { + killTables +} -returnCodes ok -result {flat} + +test config-4.75 {DoObjConfig - cursor} -constraints testobjconfig -body { + testobjconfig alltypes .foo -cursor arrow +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.76 {DoObjConfig - cursor} -constraints testobjconfig -body { + testobjconfig alltypes .foo -cursor arrow + .foo cget -cursor +} -cleanup { + killTables +} -returnCodes ok -result {arrow} +test config-4.77 {DoObjConfig - invalid cursor} -constraints testobjconfig -body { + testobjconfig alltypes .foo -cursor foo +} -cleanup { + killTables +} -returnCodes error -result {bad cursor spec "foo"} +test config-4.78 {DoObjConfig - null cursor} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -cursor {} +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.79 {DoObjConfig - null cursor} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -cursor {} + .foo cget -cursor +} -cleanup { + killTables +} -returnCodes ok -result {} +test config-4.80 {DoObjConfig - new cursor} -constraints testobjconfig -body { + testobjconfig alltypes .foo -cursor xterm + .foo configure -cursor arrow +} -cleanup { + killTables +} -returnCodes ok -result {1024} +test config-4.81 {DoObjConfig - new cursor} -constraints testobjconfig -body { + testobjconfig alltypes .foo -cursor xterm + .foo configure -cursor arrow + .foo cget -cursor +} -cleanup { + killTables +} -returnCodes ok -result {arrow} +test config-4.82 {DoObjConfig - cursor internal value} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { + testobjconfig internal .foo -cursor watch + .foo cget -cursor +} -cleanup { + killTables +} -result {watch} + +test config-4.83 {DoObjConfig - justify} -constraints testobjconfig -body { + testobjconfig alltypes .foo -justify center +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.84 {DoObjConfig - justify} -constraints testobjconfig -body { + testobjconfig alltypes .foo -justify center + .foo cget -justify +} -cleanup { + killTables +} -returnCodes ok -result {center} +test config-4.85 {DoObjConfig - invalid justify} -constraints testobjconfig -body { + testobjconfig alltypes .foo -justify foo +} -cleanup { + killTables +} -returnCodes error -result {bad justification "foo": must be left, right, or center} +test config-4.86 {DoObjConfig - new justify} -constraints testobjconfig -body { + testobjconfig alltypes .foo -justify left + .foo configure -justify right +} -cleanup { + killTables +} -returnCodes ok -result {2048} +test config-4.87 {DoObjConfig - new justify} -constraints testobjconfig -body { + testobjconfig alltypes .foo -justify left + .foo configure -justify right + .foo cget -justify +} -cleanup { + killTables +} -returnCodes ok -result {right} +test config-4.88 {DoObjConfig - justify internal value} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { + testobjconfig internal .foo -justify center + .foo cget -justify +} -cleanup { + killTables +} -result {center} + +test config-4.89 {DoObjConfig - anchor} -constraints testobjconfig -body { + testobjconfig alltypes .foo -anchor center +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.90 {DoObjConfig - anchor} -constraints testobjconfig -body { + testobjconfig alltypes .foo -anchor center + .foo cget -anchor +} -cleanup { + killTables +} -returnCodes ok -result {center} +test config-4.91 {DoObjConfig - invalid anchor} -constraints testobjconfig -body { + testobjconfig alltypes .foo -anchor foo +} -cleanup { + killTables +} -returnCodes error -result {bad anchor "foo": must be n, ne, e, se, s, sw, w, nw, or center} +test config-4.92 {DoObjConfig - new anchor} -constraints testobjconfig -body { + testobjconfig alltypes .foo -anchor e + .foo configure -anchor n +} -cleanup { + killTables +} -returnCodes ok -result {4096} +test config-4.93 {DoObjConfig - new anchor} -constraints testobjconfig -body { + testobjconfig alltypes .foo -anchor e + .foo configure -anchor n + .foo cget -anchor +} -cleanup { + killTables +} -returnCodes ok -result {n} +test config-4.94 {DoObjConfig - anchor internal value} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { + testobjconfig internal .foo -anchor sw + .foo cget -anchor +} -cleanup { + killTables +} -result {sw} +test config-4.95 {DoObjConfig - pixel} -constraints testobjconfig -body { + testobjconfig alltypes .foo -pixel 42 +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.96 {DoObjConfig - pixel} -constraints testobjconfig -body { + testobjconfig alltypes .foo -pixel 42 + .foo cget -pixel +} -cleanup { + killTables +} -returnCodes ok -result {42} +test config-4.97 {DoObjConfig - invalid pixel} -constraints testobjconfig -body { + testobjconfig alltypes .foo -pixel foo +} -cleanup { + killTables +} -returnCodes error -result {bad screen distance "foo"} +test config-4.98 {DoObjConfig - new pixel} -constraints testobjconfig -body { + testobjconfig alltypes .foo -pixel 42m + .foo configure -pixel 3c +} -cleanup { + killTables +} -returnCodes ok -result {8192} +test config-4.99 {DoObjConfig - new pixel} -constraints testobjconfig -body { + testobjconfig alltypes .foo -pixel 42m + .foo configure -pixel 3c + .foo cget -pixel +} -cleanup { + killTables +} -returnCodes ok -result {3c} +test config-4.100 {DoObjConfig - pixel internal value} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { + testobjconfig internal .foo -pixel [winfo screenmmwidth .]m + set screenW [winfo screenwidth .] + set result [.foo cget -pixel] + expr {$screenW eq $result} +} -cleanup { + killTables +} -result {1} + +test config-4.101 {DoObjConfig - window} -constraints testobjconfig -body { + toplevel .bar + testobjconfig twowindows .foo -window .bar +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.102 {DoObjConfig - window} -constraints testobjconfig -body { + toplevel .bar + testobjconfig twowindows .foo -window .bar + .foo cget -window +} -cleanup { + killTables +} -returnCodes ok -result {.bar} +test config-4.103 {DoObjConfig - invalid window} -constraints testobjconfig -body { + toplevel .bar + testobjconfig twowindows .foo -window foo +} -cleanup { + killTables +} -returnCodes error -result {bad window path name "foo"} +test config-4.104 {DoObjConfig - null window} -constraints testobjconfig -body { + toplevel .bar + testobjconfig twowindows .foo -window {} +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.105 {DoObjConfig - null window} -constraints testobjconfig -body { + toplevel .bar + testobjconfig twowindows .foo -window {} + .foo cget -window +} -cleanup { + killTables +} -returnCodes ok -result {} +test config-4.106 {DoObjConfig - new window} -constraints testobjconfig -body { + toplevel .bar + toplevel .blamph + testobjconfig twowindows .foo -window .bar + .foo configure -window .blamph +} -cleanup { + killTables +} -returnCodes ok -result {0} +test config-4.107 {DoObjConfig - new window} -constraints testobjconfig -body { + toplevel .bar + toplevel .blamph + testobjconfig twowindows .foo -window .bar + .foo configure -window .blamph + .foo cget -window +} -cleanup { + killTables +} -returnCodes ok -result {.blamph} +test config-4.108 {DoObjConfig - window internal value} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { + testobjconfig internal .foo -window . + .foo cget -window +} -cleanup { + killTables +} -result {.} + +test config-4.109 {DoObjConfig - releasing old values} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { + # This test doesn't generate a useful value to check; if an + # error occurs, it will be detected only by memory checking software + # such as Purify or Tcl's built-in checker. + + testobjconfig alltypes .foo -string {Test string} -color yellow \ + -font {Courier 18} -bitmap questhead -border green -cursor cross \ + -custom foobar + .foo configure -string {new string} -color brown \ + -font {Times 8} -bitmap gray75 -border pink -cursor watch \ + -custom barbaz + concat {} +} -cleanup { + killTables +} -result {} +test config-4.110 {DoObjConfig - releasing old values} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { + # This test doesn't generate a useful value to check; if an + # error occurs, it will be detected only by memory checking software + # such as Purify or Tcl's built-in checker. + + testobjconfig internal .foo -string {Test string} -color yellow \ + -font {Courier 18} -bitmap questhead -border green -cursor cross \ + -custom foobar + .foo configure -string {new string} -color brown \ + -font {Times 8} -bitmap gray75 -border pink -cursor watch \ + -custom barbaz + concat {} +} -cleanup { + killTables +} -result {} + +test config-4.111 {DoObjConfig - custom} -constraints testobjconfig -body { + testobjconfig alltypes .foo -custom test +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.112 {DoObjConfig - custom} -constraints testobjconfig -body { + testobjconfig alltypes .foo -custom test + .foo cget -custom +} -cleanup { + killTables +} -returnCodes ok -result {TEST} +test config-4.113 {DoObjConfig - null custom} -constraints testobjconfig -body { + testobjconfig alltypes .foo -custom {} +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.114 {DoObjConfig - null custom} -constraints testobjconfig -body { + testobjconfig alltypes .foo -custom {} + .foo cget -custom +} -cleanup { + killTables +} -returnCodes ok -result {} +test config-4.115 {DoObjConfig - custom internal value} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { + testobjconfig internal .foo -custom "this is a test" + .foo cget -custom +} -cleanup { + killTables +} -result {THIS IS A TEST} + + +test config-5.1 {ObjectIsEmpty - object is already string} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -color [format ""] + .foo cget -color +} -cleanup { + killTables +} -result {} +test config-5.2 {ObjectIsEmpty - object is already string} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -color [format " "] +} -cleanup { + killTables +} -returnCodes error -result {unknown color name " "} +test config-5.3 {ObjectIsEmpty - must convert back to string} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -color [list] + .foo cget -color +} -cleanup { + killTables +} -result {} + + +test config-6.1 {GetOptionFromObj - cached answer} -constraints { + testobjconfig +} -body { + testobjconfig chain2 .a + list [.a cget -three] [.a cget -three] +} -cleanup { + killTables +} -result {three three} +test config-6.2 {GetOptionFromObj - exact match} -constraints { + testobjconfig +} -body { + testobjconfig chain2 .a + .a cget -one +} -cleanup { + killTables +} -result {one} +test config-6.3 {GetOptionFromObj - abbreviation} -constraints { + testobjconfig +} -body { + testobjconfig chain2 .a + .a cget -fo +} -cleanup { + killTables +} -result {four} +test config-6.4 {GetOptionFromObj - ambiguous abbreviation} -constraints { + testobjconfig +} -body { + testobjconfig chain2 .a + .a cget -on +} -cleanup { + killTables +} -cleanup { + killTables +} -returnCodes error -result {unknown option "-on"} +test config-6.5 {GetOptionFromObj - duplicate options in different tables} -constraints { + testobjconfig +} -body { + testobjconfig chain2 .a + .a cget -tw +} -cleanup { + killTables +} -result {two and a half} +test config-6.6 {GetOptionFromObj - synonym} -constraints testobjconfig -body { + testobjconfig alltypes .b + .b cget -synonym +} -cleanup { + killTables +} -result {red} + + +if {[testConstraint testobjconfig]} { + testobjconfig alltypes .a +} +test config-7.1 {Tk_SetOptions - basics} -constraints testobjconfig -body { + .a configure -color green -rel sunken + list [.a cget -color] [.a cget -relief] +} -result {green sunken} +test config-7.2 {Tk_SetOptions - bogus option name} -constraints { + testobjconfig +} -body { + .a configure -bogus +} -returnCodes error -result {unknown option "-bogus"} +test config-7.3 {Tk_SetOptions - synonym} -constraints testobjconfig -body { + .a configure -synonym blue + .a cget -color +} -result {blue} +test config-7.4 {Tk_SetOptions - missing value} -constraints { + testobjconfig +} -body { + .a configure -color green -relief +} -returnCodes error -result {value for "-relief" missing} +test config-7.5 {Tk_SetOptions - missing value} -constraints { + testobjconfig +} -body { + catch {.a configure -color green -relief} + .a cget -color +} -result {green} +test config-7.6 {Tk_SetOptions - saving old values} -constraints { + testobjconfig +} -body { + .a configure -color red -int 7 -relief raised -double 3.14159 + .a csave -color green -int 432 -relief sunken -double 2.0 -color bogus +} -returnCodes error -result {unknown color name "bogus"} +test config-7.7 {Tk_SetOptions - saving old values} -constraints { + testobjconfig +} -body { + .a configure -color red -int 7 -relief raised -double 3.14159 + catch {.a csave -color green -int 432 -relief sunken -double 2.0 -color bogus} + list [.a cget -color] [.a cget -int] [.a cget -relief] [.a cget -double] +} -result {red 7 raised 3.14159} + +test config-7.8 {Tk_SetOptions - error in DoObjConfig call} -constraints { + testobjconfig +} -body { + .a configure -color bogus +} -returnCodes error -result {unknown color name "bogus"} +test config-7.9 {Tk_SetOptions - error in DoObjConfig call} -constraints { + testobjconfig +} -body { + catch {.a configure -color bogus} + return $errorInfo +} -result {unknown color name "bogus" + (processing "-color" option) + invoked from within +".a configure -color bogus"} + +test config-7.10 {Tk_SetOptions - synonym name in error message} -constraints { + testobjconfig +} -body { + .a configure -synonym bogus +} -returnCodes error -result {unknown color name "bogus"} +test config-7.11 {Tk_SetOptions - synonym name in error message} -constraints { + testobjconfig +} -body { + catch {.a configure -synonym bogus} + return $errorInfo +} -result {unknown color name "bogus" + (processing "-synonym" option) + invoked from within +".a configure -synonym bogus"} +test config-7.12 {Tk_SetOptions - returning mask} -constraints testobjconfig -body { + format %x [.a configure -color red -int 7 -relief raised -double 3.14159] +} -result {226} +test config-7.13 {Tk_SetOptions - error in DoObjConfig with custom option} -constraints { + testobjconfig +} -body { + .a configure -custom bad +} -returnCodes error -result {expected good value, got "BAD"} +test config-7.14 {Tk_SetOptions - error in DoObjConfig with custom option} -constraints { + testobjconfig +} -body { + catch {.a configure -custom bad} + return $errorInfo +} -result {expected good value, got "BAD" + (processing "-custom" option) + invoked from within +".a configure -custom bad"} +if {[testConstraint testobjconfig]} { + killTables +} + + +test config-8.1 {Tk_RestoreSavedOptions - restore in proper order} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .a + .a csave -color green -color black -color blue \ + -color #ffff00 -color #ff00ff -color bogus \ +} -cleanup { + killTables +} -returnCodes error -result {unknown color name "bogus"} +test config-8.2 {Tk_RestoreSavedOptions - restore in proper order} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .a + catch {.a csave -color green -color black -color blue \ + -color #ffff00 -color #ff00ff -color bogus} + .a cget -color +} -cleanup { + killTables +} -result {red} +test config-8.3 {Tk_RestoreSavedOptions - freeing object memory} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .a + .a csave -color green -color black -color blue -color #ffff00 -color #ff00ff +} -cleanup { + killTables +} -result {32} +test config-8.4 {Tk_RestoreSavedOptions - boolean internal form} -constraints { + testobjconfig +} -body { + testobjconfig internal .a + .a csave -boolean 0 -color bogus +} -cleanup { + killTables +} -returnCodes error -match glob -result * +test config-8.5 {Tk_RestoreSavedOptions - boolean internal form} -constraints { + testobjconfig +} -body { + testobjconfig internal .a + catch {.a csave -boolean 0 -color bogus} + .a cget -boolean +} -cleanup { + killTables +} -result {1} +test config-8.6 {Tk_RestoreSavedOptions - integer internal form} -constraints { + testobjconfig +} -body { + testobjconfig internal .a + .a csave -integer 24 -color bogus +} -cleanup { + killTables +} -returnCodes error -match glob -result * +test config-8.7 {Tk_RestoreSavedOptions - integer internal form} -constraints { + testobjconfig +} -body { + testobjconfig internal .a + catch {.a csave -integer 24 -color bogus} + .a cget -integer +} -cleanup { + killTables +} -result {148962237} +test config-8.8 {Tk_RestoreSavedOptions - double internal form} -constraints { + testobjconfig +} -body { + testobjconfig internal .a + catch {.a csave -double 62.4 -color bogus} + .a cget -double +} -cleanup { + killTables +} -result {3.14159} +test config-8.9 {Tk_RestoreSavedOptions - string internal form} -constraints { + testobjconfig +} -body { + testobjconfig internal .a + catch {.a csave -string "A long string" -color bogus} + .a cget -string +} -cleanup { + killTables +} -result {foo} +test config-8.10 {Tk_RestoreSavedOptions - string table internal form} -constraints { + testobjconfig +} -body { + testobjconfig internal .a + catch {.a csave -stringtable three -color bogus} + .a cget -stringtable +} -cleanup { + killTables +} -result {one} +test config-8.11 {Tk_RestoreSavedOptions - color internal form} -constraints { + testobjconfig +} -body { + testobjconfig internal .a + catch {.a csave -color green -color bogus} + .a cget -color +} -cleanup { + killTables +} -result {red} +test config-8.12 {Tk_RestoreSavedOptions - font internal form} -constraints { + testobjconfig nonPortable +} -body { + testobjconfig internal .a + catch {.a csave -font {Times 12} -color bogus} + .a cget -font +} -cleanup { + killTables +} -result {Helvetica 12} +test config-8.13 {Tk_RestoreSavedOptions - bitmap internal form} -constraints { + testobjconfig +} -body { + testobjconfig internal .a + catch {.a csave -bitmap questhead -color bogus} + .a cget -bitmap +} -cleanup { + killTables +} -result {gray50} +test config-8.14 {Tk_RestoreSavedOptions - border internal form} -constraints { + testobjconfig +} -body { + testobjconfig internal .a + catch {.a csave -border brown -color bogus} + .a cget -border +} -cleanup { + killTables +} -result {blue} +test config-8.15 {Tk_RestoreSavedOptions - relief internal form} -constraints { + testobjconfig +} -body { + testobjconfig internal .a + catch {.a csave -relief sunken -color bogus} + .a cget -relief +} -cleanup { + killTables +} -result {raised} +test config-8.16 {Tk_RestoreSavedOptions - cursor internal form} -constraints { + testobjconfig +} -body { + testobjconfig internal .a + catch {.a csave -cursor watch -color bogus} + .a cget -cursor +} -cleanup { + killTables +} -result {xterm} +test config-8.17 {Tk_RestoreSavedOptions - justify internal form} -constraints { + testobjconfig +} -body { + testobjconfig internal .a + catch {.a csave -justify right -color bogus} + .a cget -justify +} -cleanup { + killTables +} -result {left} +test config-8.18 {Tk_RestoreSavedOptions - anchor internal form} -constraints { + testobjconfig +} -body { + testobjconfig internal .a + catch {.a csave -anchor center -color bogus} + .a cget -anchor +} -cleanup { + killTables +} -result {n} +test config-8.19 {Tk_RestoreSavedOptions - window internal form} -constraints { + testobjconfig +} -body { + testobjconfig internal .a -window .a + catch {.a csave -window .a -color bogus} + .a cget -window +} -cleanup { + killTables +} -result {.a} +test config-8.20 {Tk_RestoreSavedOptions - custom internal form} -constraints { + testobjconfig +} -body { + testobjconfig internal .a -custom "foobar" + catch {.a csave -custom "barbaz" -color bogus} + .a cget -custom +} -cleanup { + killTables +} -result {FOOBAR} + +# Most of the tests below will cause memory leakage if there is a +# problem. This may not be evident unless the tests are run in +# conjunction with a memory usage analyzer such as Purify. + +test config-9.1 {Tk_FreeConfigOptions/FreeResources - string internal form} -constraints { + testobjconfig +} -body { + testobjconfig internal .foo + .foo configure -string "two words" + destroy .foo +} -result {} +test config-9.2 {Tk_FreeConfigOptions/FreeResources - color internal form} -constraints { + testobjconfig +} -body { + testobjconfig internal .foo + .foo configure -color yellow + destroy .foo +} -result {} +test config-9.3 {Tk_FreeConfigOptions/FreeResources - color} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo + .foo configure -color [format blue] + destroy .foo +} -result {} +test config-9.4 {Tk_FreeConfigOptions/FreeResources - font internal form} -constraints { + testobjconfig +} -body { + testobjconfig internal .foo + .foo configure -font {Courier 20} + destroy .foo +} -result {} +test config-9.5 {Tk_FreeConfigOptions/FreeResources - font} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo + .foo configure -font [format {Courier 24}] + destroy .foo +} -result {} +test config-9.6 {Tk_FreeConfigOptions/FreeResources - bitmap internal form} -constraints { + testobjconfig +} -body { + testobjconfig internal .foo + .foo configure -bitmap gray75 + destroy .foo +} -result {} +test config-9.7 {Tk_FreeConfigOptions/FreeResources - bitmap} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo + .foo configure -bitmap [format gray75] + destroy .foo +} -result {} +test config-9.8 {Tk_FreeConfigOptions/FreeResources - border internal form} -constraints { + testobjconfig +} -body { + testobjconfig internal .foo + .foo configure -border orange + destroy .foo +} -result {} +test config-9.9 {Tk_FreeConfigOptions/FreeResources - border} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo + .foo configure -border [format blue] + destroy .foo +} -result {} +test config-9.10 {Tk_FreeConfigOptions/FreeResources - cursor internal form} -constraints { + testobjconfig +} -body { + testobjconfig internal .foo + .foo configure -cursor cross + destroy .foo +} -result {} +test config-9.11 {Tk_FreeConfigOptions/FreeResources - cursor} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo + .foo configure -cursor [format watch] + destroy .foo +} -result {} +test config-9.12 {Tk_FreeConfigOptions/FreeResources - not special} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo + .foo configure -integer [format 27] + destroy .foo +} -result {} +test config-9.13 {Tk_FreeConfigOptions/FreeResources - custom internal form} -constraints { + testobjconfig +} -body { + catch {destroy .fpp} + testobjconfig internal .foo + .foo configure -custom "foobar" + destroy .foo +} -result {} +if {[testConstraint testobjconfig]} { + killTables +} + + +test config-10.1 {Tk_GetOptionInfo - one item} -constraints testobjconfig -body { + testobjconfig alltypes .foo + .foo configure -relief groove + .foo configure -relief +} -cleanup { + destroy .foo +} -result {-relief relief Relief raised groove} +test config-10.2 {Tk_GetOptionInfo - one item, synonym} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo + .foo configure -color black + .foo configure -synonym +} -cleanup { + destroy .foo +} -result {-color color Color red black} +test config-10.3 {Tk_GetOptionInfo - all items} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -font {Helvetica 18} -integer 13563 + .foo configure +} -cleanup { + destroy .foo +} -result {{-boolean boolean Boolean 1 1} {-integer integer Integer 7 13563} {-double double Double 3.14159 3.14159} {-string string String foo foo} {-stringtable StringTable stringTable one one} {-color color Color red red} {-font font Font {Helvetica 12} {Helvetica 18}} {-bitmap bitmap Bitmap gray50 gray50} {-border border Border blue blue} {-relief relief Relief raised raised} {-cursor cursor Cursor xterm xterm} {-justify {} {} left left} {-anchor anchor Anchor {} {}} {-pixel pixel Pixel 1 1} {-custom {} {} {} {}} {-synonym -color}} +test config-10.4 {Tk_GetOptionInfo - chaining through tables} -constraints testobjconfig -body { + testobjconfig chain2 .foo -one asdf -three xyzzy + .foo configure +} -cleanup { + destroy .foo +} -result {{-three three Three three xyzzy} {-four four Four four four} {-two two Two {two and a half} {two and a half}} {-oneAgain oneAgain OneAgain {one again} {one again}} {-one one One one asdf} {-two two Two two {two and a half}}} +if {[testConstraint testobjconfig]} { + killTables +} + + +if {[testConstraint testobjconfig]} { + testobjconfig alltypes .a +} +test config-11.1 {GetConfigList - synonym} -constraints testobjconfig -body { + lindex [.a configure] end +} -result {-synonym -color} +test config-11.2 {GetConfigList - null database names} -constraints { + testobjconfig +} -body { + .a configure -justify +} -result {-justify {} {} left left} +test config-11.3 {GetConfigList - null default and current value} -constraints { + testobjconfig +} -body { + .a configure -anchor +} -result {-anchor anchor Anchor {} {}} +if {[testConstraint testobjconfig]} { + killTables +} + + +if {[testConstraint testobjconfig]} { + testobjconfig internal .a +} +test config-12.1 {GetObjectForOption - boolean} -constraints testobjconfig -body { + .a configure -boolean 0 + .a cget -boolean +} -result {0} +test config-12.2 {GetObjectForOption - integer} -constraints testobjconfig -body { + .a configure -integer 1247 + .a cget -integer +} -result {1247} +test config-12.3 {GetObjectForOption - double} -constraints testobjconfig -body { + .a configure -double -88.82 + .a cget -double +} -result {-88.82} +test config-12.4 {GetObjectForOption - string} -constraints testobjconfig -body { + .a configure -string "test value" + .a cget -string +} -result {test value} +test config-12.5 {GetObjectForOption - stringTable} -constraints { + testobjconfig +} -body { + .a configure -stringtable "two" + .a cget -stringtable +} -result {two} +test config-12.6 {GetObjectForOption - color} -constraints testobjconfig -body { + .a configure -color "green" + .a cget -color +} -result {green} +test config-12.7 {GetObjectForOption - font} -constraints testobjconfig -body { + .a configure -font {Times 36} + .a cget -font +} -result {Times 36} +test config-12.8 {GetObjectForOption - bitmap} -constraints testobjconfig -body { + .a configure -bitmap "questhead" + .a cget -bitmap +} -result {questhead} +test config-12.9 {GetObjectForOption - border} -constraints testobjconfig -body { + .a configure -border #33217c + .a cget -border +} -result {#33217c} +test config-12.10 {GetObjectForOption - relief} -constraints { + testobjconfig +} -body { + .a configure -relief groove + .a cget -relief +} -result {groove} +test config-12.11 {GetObjectForOption - cursor} -constraints { + testobjconfig +} -body { + .a configure -cursor watch + .a cget -cursor +} -result {watch} +test config-12.12 {GetObjectForOption - justify} -constraints { + testobjconfig +} -body { + .a configure -justify right + .a cget -justify +} -result {right} +test config-12.13 {GetObjectForOption - anchor} -constraints testobjconfig -body { + .a configure -anchor e + .a cget -anchor +} -result {e} +test config-12.14 {GetObjectForOption - pixels} -constraints testobjconfig -body { + .a configure -pixel 193.2 + .a cget -pixel +} -result {193} +test config-12.15 {GetObjectForOption - window} -constraints testobjconfig -body { + .a configure -window .a + .a cget -window +} -result {.a} +test config-12.16 {GetObjectForOption -custom} -constraints testobjconfig -body { + .a configure -custom foobar + .a cget -custom +} -result {FOOBAR} +test config-12.17 {GetObjectForOption - null values} -constraints { + testobjconfig +} -body { + .a configure -string {} -color {} -font {} -bitmap {} -border {} \ + -cursor {} -window {} -custom {} + list [.a cget -string] [.a cget -color] [.a cget -font] \ + [.a cget -bitmap] [.a cget -border] [.a cget -cursor] \ + [.a cget -window] [.a cget -custom] +} -result {{} {} {} {} {} {} {} {}} +if {[testConstraint testobjconfig]} { + killTables +} + + +test config-13.1 {proper cleanup of options with widget destroy} -body { + button .w -cursor crosshair + destroy .w +} -result {} +test config-13.2 {proper cleanup of options with widget destroy} -body { + canvas .w -cursor crosshair + destroy .w +} -result {} +test config-13.3 {proper cleanup of options with widget destroy} -body { + entry .w -cursor crosshair + destroy .w +} -result {} +test config-13.4 {proper cleanup of options with widget destroy} -body { + frame .w -cursor crosshair + destroy .w +} -result {} +test config-13.5 {proper cleanup of options with widget destroy} -body { + listbox .w -cursor crosshair + destroy .w +} -result {} +test config-13.6 {proper cleanup of options with widget destroy} -body { + menu .w -cursor crosshair + destroy .w +} -result {} +test config-13.7 {proper cleanup of options with widget destroy} -body { + menubutton .w -cursor crosshair + destroy .w +} -result {} +test config-13.8 {proper cleanup of options with widget destroy} -body { + message .w -cursor crosshair + destroy .w +} -result {} +test config-13.9 {proper cleanup of options with widget destroy} -body { + scale .w -cursor crosshair + destroy .w +} -result {} +test config-13.10 {proper cleanup of options with widget destroy} -body { + scrollbar .w -cursor crosshair + destroy .w +} -result {} +test config-13.11 {proper cleanup of options with widget destroy} -body { + text .w -cursor crosshair + destroy .w +} -result {} +test config-13.12 {proper cleanup of options with widget destroy} -body { + radiobutton .w -cursor crosshair + destroy .w +} -result {} +test config-13.13 {proper cleanup of options with widget destroy} -body { + checkbutton .w -cursor crosshair + destroy .w +} -result {} + +test config-14.1 {Tk_CreateOptionTable - use with namespace import} -setup { + namespace export -clear * +} -body { + namespace eval ::foo [subst { + namespace import -force ::button + ::foo::button .a + ::foo::button .b + } + ] + destroy .a .b +} -result {} +test config-14.2 {Tk_CreateOptionTable - use with namespace import} -setup { + namespace export -clear * +} -body { + namespace eval ::foo [subst { + namespace import -force ::canvas + ::foo::canvas .a + ::foo::canvas .b + } + ] + destroy .a .b +} -result {} +test config-14.3 {Tk_CreateOptionTable - use with namespace import} -setup { + namespace export -clear * +} -body { + namespace eval ::foo [subst { + namespace import -force ::entry + ::foo::entry .a + ::foo::entry .b + } + ] + destroy .a .b +} -result {} +test config-14.4 {Tk_CreateOptionTable - use with namespace import} -setup { + namespace export -clear * +} -body { + namespace eval ::foo [subst { + namespace import -force ::frame + ::foo::frame .a + ::foo::frame .b + } + ] + destroy .a .b +} -result {} +test config-14.5 {Tk_CreateOptionTable - use with namespace import} -setup { + namespace export -clear * +} -body { + namespace eval ::foo [subst { + namespace import -force ::listbox + ::foo::listbox .a + ::foo::listbox .b + } + ] + destroy .a .b +} -result {} +test config-14.6 {Tk_CreateOptionTable - use with namespace import} -setup { + namespace export -clear * +} -body { + namespace eval ::foo [subst { + namespace import -force ::menu + ::foo::menu .a + ::foo::menu .b + } + ] + destroy .a .b +} -result {} +test config-14.7 {Tk_CreateOptionTable - use with namespace import} -setup { + namespace export -clear * +} -body { + namespace eval ::foo [subst { + namespace import -force ::menubutton + ::foo::menubutton .a + ::foo::menubutton .b + } + ] + destroy .a .b +} -result {} +test config-14.8 {Tk_CreateOptionTable - use with namespace import} -setup { + namespace export -clear * +} -body { + namespace eval ::foo [subst { + namespace import -force ::message + ::foo::message .a + ::foo::message .b + } + ] + destroy .a .b +} -result {} +test config-14.9 {Tk_CreateOptionTable - use with namespace import} -setup { + namespace export -clear * +} -body { + namespace eval ::foo [subst { + namespace import -force ::scale + ::foo::scale .a + ::foo::scale .b + } + ] + destroy .a .b +} -result {} +test config-14.10 {Tk_CreateOptionTable - use with namespace import} -setup { + namespace export -clear * +} -body { + namespace eval ::foo [subst { + namespace import -force ::scrollbar + ::foo::scrollbar .a + ::foo::scrollbar .b + } + ] + destroy .a .b +} -result {} +test config-14.11 {Tk_CreateOptionTable - use with namespace import} -setup { + namespace export -clear * +} -body { + namespace eval ::foo [subst { + namespace import -force ::spinbox + ::foo::spinbox .a + ::foo::spinbox .b + } + ] + destroy .a .b +} -result {} +test config-14.12 {Tk_CreateOptionTable - use with namespace import} -setup { + namespace export -clear * +} -body { + namespace eval ::foo [subst { + namespace import -force ::text + ::foo::text .a + ::foo::text .b + } + ] + destroy .a .b +} -result {} +test config-14.13 {Tk_CreateOptionTable - use with namespace import} -setup { + namespace export -clear * +} -body { + namespace eval ::foo [subst { + namespace import -force ::radiobutton + ::foo::radiobutton .a + ::foo::radiobutton .b + } + ] + destroy .a .b +} -result {} +test config-14.14 {Tk_CreateOptionTable - use with namespace import} -setup { + namespace export -clear * +} -body { + namespace eval ::foo [subst { + namespace import -force ::checkbutton + ::foo::checkbutton .a + ::foo::checkbutton .b + } + ] + destroy .a .b +} -result {} + + +# cleanup +deleteWindows +if {[testConstraint testobjconfig]} { + killTables +} +cleanupTests +return + + + + + + + + |