tk/tests/config.test

   1 # This file is a Tcl script to test the procedures in tkConfig.c,
   2 # which comprise the new new option configuration system.  It is
   3 # organized in the standard "white-box" fashion for Tcl tests.
   4 #
   5 # Copyright (c) 1997 Sun Microsystems, Inc.
   6 # Copyright (c) 1998-1999 by Scriptics Corporation.
   7 # All rights reserved.
   8 #
   9 # RCS: @(#) $Id$
  10
  11 package require tcltest 2.1
  12 namespace import -force tcltest::configure
  13 namespace import -force tcltest::testsDirectory
  14 configure -testdir [file join [pwd] [file dirname [info script]]]
  15 configure -loadfile [file join [testsDirectory] constraints.tcl]
  16 tcltest::loadTestedCommands
  17
  18 testConstraint testobjconfig [llength [info commands testobjconfig]]
  19
  20 proc killTables {} {
  21     # Note: it's important to delete chain2 before chain1, because
  22     # chain2 depends on chain1.  If chain1 is deleted first, the
  23     # delete of chain2 will crash.
  24
  25     foreach t {alltypes chain2 chain1 configerror internal new notenoughparams
  26             twowindows} {
  27         while {[testobjconfig info $t] != ""} {
  28             testobjconfig delete $t
  29         }
  30     }
  31 }
  32
  33 if {[testConstraint testobjconfig]} {
  34     killTables
  35 }
  36
  37 test config-1.1 {Tk_CreateOptionTable - reference counts} testobjconfig {
  38     deleteWindows
  39     killTables
  40     set x {}
  41     testobjconfig alltypes .a
  42     lappend x [testobjconfig info alltypes]
  43     testobjconfig alltypes .b
  44     lappend x [testobjconfig info alltypes]
  45     deleteWindows
  46     set x
  47 } {{1 16 -boolean} {2 16 -boolean}}
  48 test config-1.2 {Tk_CreateOptionTable - synonym initialization} testobjconfig {
  49     deleteWindows
  50     testobjconfig alltypes .a -synonym green
  51     .a cget -color
  52 } {green}
  53 test config-1.3 {Tk_CreateOptionTable - option database initialization} testobjconfig {
  54     deleteWindows
  55     option clear
  56     testobjconfig alltypes .a
  57     option add *b.string different
  58     testobjconfig alltypes .b
  59     list [.a cget -string] [.b cget -string]
  60 } {foo different}
  61 test config-1.4 {Tk_CreateOptionTable - option database initialization} testobjconfig {
  62     deleteWindows
  63     option clear
  64     testobjconfig alltypes .a
  65     option add *b.String bar
  66     testobjconfig alltypes .b
  67     list [.a cget -string] [.b cget -string]
  68 } {foo bar}
  69 test config-1.5 {Tk_CreateOptionTable - default initialization} testobjconfig {
  70     deleteWindows
  71     testobjconfig alltypes .a
  72     .a cget -relief
  73 } {raised}
  74 test config-1.6 {Tk_CreateOptionTable - chained tables} testobjconfig {
  75     deleteWindows
  76     killTables
  77     testobjconfig chain1 .a
  78     testobjconfig chain2 .b
  79     testobjconfig info chain2
  80 } {1 4 -three 2 2 -one}
  81 test config-1.7 {Tk_CreateOptionTable - chained tables} testobjconfig {
  82     deleteWindows
  83     killTables
  84     testobjconfig chain2 .b
  85     testobjconfig chain1 .a
  86     testobjconfig info chain2
  87 } {1 4 -three 2 2 -one}
  88 test config-1.8 {Tk_CreateOptionTable - chained tables} testobjconfig {
  89     deleteWindows
  90     testobjconfig chain1 .a
  91     testobjconfig chain2 .b
  92     list [catch {.a cget -four} msg] $msg [.a cget -one] \
  93             [.b cget -four] [.b cget -one]
  94 } {1 {unknown option "-four"} one four one}
  95
  96 test config-2.1 {Tk_DeleteOptionTable - reference counts} testobjconfig {
  97     deleteWindows
  98     killTables
  99     testobjconfig chain1 .a
 100     testobjconfig chain2 .b
 101     testobjconfig chain2 .c
 102     deleteWindows
 103     set x {}
 104     testobjconfig delete chain2
 105     lappend x [testobjconfig info chain2] [testobjconfig info chain1]
 106     testobjconfig delete chain2
 107     lappend x [testobjconfig info chain2] [testobjconfig info chain1]
 108 } {{1 4 -three 2 2 -one} {2 2 -one} {} {1 2 -one}}
 109
 110 # No tests for DestroyOptionHashTable; couldn't figure out how to test.
 111
 112 test config-3.1 {Tk_InitOptions - priority of chained tables} testobjconfig {
 113     deleteWindows
 114     testobjconfig chain1 .a
 115     testobjconfig chain2 .b
 116     list [.a cget -two] [.b cget -two]
 117 } {two {two and a half}}
 118 test config-3.2 {Tk_InitOptions - initialize from database} testobjconfig {
 119     deleteWindows
 120     option clear
 121     option add *a.color blue
 122     testobjconfig alltypes .a
 123     list [.a cget -color]
 124 } {blue}
 125 test config-3.3 {Tk_InitOptions - initialize from database} testobjconfig {
 126     deleteWindows
 127     option clear
 128     option add *a.justify bogus
 129     testobjconfig alltypes .a
 130     list [.a cget -justify]
 131 } {left}
 132 test config-3.4 {Tk_InitOptions - initialize from widget class} testobjconfig {
 133     deleteWindows
 134     testobjconfig alltypes .a
 135     list [.a cget -color]
 136 } {red}
 137 test config-3.5 {Tk_InitOptions - no initial value} testobjconfig {
 138     deleteWindows
 139     testobjconfig alltypes .a
 140     .a cget -anchor
 141 } {}
 142 test config-3.6 {Tk_InitOptions - bad initial value} testobjconfig {
 143     deleteWindows
 144     option clear
 145     option add *a.color non-existent
 146     list [catch {testobjconfig alltypes .a} msg] $msg $errorInfo
 147 } {1 {unknown color name "non-existent"} {unknown color name "non-existent"
 148     (database entry for "-color" in widget ".a")
 149     invoked from within
 150 "testobjconfig alltypes .a"}}
 151 option clear
 152 test config-3.7 {Tk_InitOptions - bad initial value} testobjconfig {
 153     deleteWindows
 154     list [catch {testobjconfig configerror} msg] $msg $errorInfo
 155 } {1 {expected integer but got "bogus"} {expected integer but got "bogus"
 156     (default value for "-int")
 157     invoked from within
 158 "testobjconfig configerror"}}
 159 option clear
 160
 161 test config-4.1 {DoObjConfig - boolean} testobjconfig {
 162     catch {rename .foo {}}
 163     list [catch {testobjconfig alltypes .foo -boolean 0} msg] $msg [catch {.foo cget -boolean} result] $result [catch {rename .foo {}}]
 164 } {0 .foo 0 0 0}
 165 test config-4.2 {DoObjConfig - boolean} testobjconfig {
 166     catch {rename .foo {}}
 167     list [catch {testobjconfig alltypes .foo -boolean 1} msg] $msg [catch {.foo cget -boolean} result] $result [catch {rename .foo {}}]
 168 } {0 .foo 0 1 0}
 169 test config-4.3 {DoObjConfig - invalid boolean} testobjconfig {
 170     catch {rename .foo {}}
 171     list [catch {testobjconfig alltypes .foo -boolean {}} msg] $msg
 172 } {1 {expected boolean value but got ""}}
 173 test config-4.4 {DoObjConfig - boolean internal value} testobjconfig {
 174     catch {rename .foo {}}
 175     testobjconfig internal .foo -boolean 0
 176     .foo cget -boolean
 177 } {0}
 178 test config-4.5 {DoObjConfig - integer} testobjconfig {
 179     catch {rename .foo {}}
 180     list [catch {testobjconfig alltypes .foo -integer 3} msg] $msg [catch {.foo cget -integer} result] $result [catch {rename .foo {}}]
 181 } {0 .foo 0 3 0}
 182 test config-4.6 {DoObjConfig - invalid integer} testobjconfig {
 183     catch {rename .foo {}}
 184     list [catch {testobjconfig alltypes .foo -integer bar} msg] $msg
 185 } {1 {expected integer but got "bar"}}
 186 test config-4.7 {DoObjConfig - integer internal value} testobjconfig {
 187     catch {rename .foo {}}
 188     testobjconfig internal .foo -integer 421
 189     .foo cget -integer
 190 } {421}
 191 test config-4.8 {DoObjConfig - double} testobjconfig {
 192     catch {rename .foo {}}
 193     list [catch {testobjconfig alltypes .foo -double 3.14} msg] $msg [catch {.foo cget -double} result] $result [catch {rename .foo {}}]
 194 } {0 .foo 0 3.14 0}
 195 test config-4.9 {DoObjConfig - invalid double} testobjconfig {
 196     catch {rename .foo {}}
 197     list [catch {testobjconfig alltypes .foo -double bar} msg] $msg
 198 } {1 {expected floating-point number but got "bar"}}
 199 test config-4.10 {DoObjConfig - double internal value} testobjconfig {
 200     catch {rename .foo {}}
 201     testobjconfig internal .foo -double 62.75
 202     .foo cget -double
 203 } {62.75}
 204 test config-4.11 {DoObjConfig - string} testobjconfig {
 205     catch {destroy .foo}
 206     list [catch {testobjconfig alltypes .foo -string test} msg] $msg [catch {.foo cget -string} result] $result [destroy .foo]
 207 } {0 .foo 0 test {}}
 208 test config-4.12 {DoObjConfig - null string} testobjconfig {
 209     catch {destroy .foo}
 210     list [catch {testobjconfig alltypes .foo -string {}} msg] $msg [catch {.foo cget -string} result] $result [destroy .foo]
 211 } {0 .foo 0 {} {}}
 212 test config-4.13 {DoObjConfig - string internal value} testobjconfig {
 213     catch {rename .foo {}}
 214     testobjconfig internal .foo -string "this is a test"
 215     .foo cget -string
 216 } {this is a test}
 217 test config-4.14 {DoObjConfig - string table} testobjconfig {
 218     catch {destroy .foo}
 219     list [catch {testobjconfig alltypes .foo -stringtable two} msg] $msg [catch {.foo cget -stringtable} result] $result [destroy .foo]
 220 } {0 .foo 0 two {}}
 221 test config-4.15 {DoObjConfig - invalid string table} testobjconfig {
 222     catch {destroy .foo}
 223     list [catch {testobjconfig alltypes .foo -stringtable foo} msg] $msg
 224 } {1 {bad stringtable "foo": must be one, two, three, or four}}
 225 test config-4.16 {DoObjConfig - new string table} testobjconfig {
 226     catch {destroy .foo}
 227     testobjconfig alltypes .foo -stringtable two
 228     list [catch {.foo configure -stringtable three} msg] $msg [catch {.foo cget -stringtable} result] $result [destroy .foo]
 229 } {0 16 0 three {}}
 230 test config-4.17 {DoObjConfig - stringtable internal value} testobjconfig {
 231     catch {rename .foo {}}
 232     testobjconfig internal .foo -stringtable "four"
 233     .foo cget -stringtable
 234 } {four}
 235 test config-4.18 {DoObjConfig - color} testobjconfig {
 236     catch {rename .foo {}}
 237     list [catch {testobjconfig alltypes .foo -color blue} msg] $msg [catch {.foo cget -color} result] $result [destroy .foo]
 238 } {0 .foo 0 blue {}}
 239 test config-4.19 {DoObjConfig - invalid color} testobjconfig {
 240     catch {destroy .foo}
 241     list [catch {testobjconfig alltypes .foo -color xxx} msg] $msg
 242 } {1 {unknown color name "xxx"}}
 243 test config-4.20 {DoObjConfig - color internal value} testobjconfig {
 244     catch {rename .foo {}}
 245     testobjconfig internal .foo -color purple
 246     .foo cget -color
 247 } {purple}
 248 test config-4.21 {DoObjConfig - null color} testobjconfig {
 249     catch {rename .foo {}}
 250     list [catch {testobjconfig alltypes .foo -color {}} msg] $msg [catch {.foo cget -color} result] $result [destroy .foo]
 251 } {0 .foo 0 {} {}}
 252 test config-4.22 {DoObjConfig - getting rid of old color} testobjconfig {
 253     catch {destroy .foo}
 254     testobjconfig alltypes .foo -color #333333
 255     list [catch {.foo configure -color #444444} msg] $msg [catch {.foo cget -color} result] $result [destroy .foo]
 256 } {0 32 0 #444444 {}}
 257 test config-4.23 {DoObjConfig - font} testobjconfig {
 258     catch {rename .foo {}}
 259     list [catch {testobjconfig alltypes .foo -font {Helvetica 72}} msg] $msg [catch {.foo cget -font} result] $result [destroy .foo]
 260 } {0 .foo 0 {Helvetica 72} {}}
 261 test config-4.24 {DoObjConfig - new font} testobjconfig {
 262     catch {rename .foo {}}
 263     testobjconfig alltypes .foo -font {Courier 12}
 264     list [catch {.foo configure -font {Helvetica 72}} msg] $msg [catch {.foo cget -font} result] $result [destroy .foo]
 265 } {0 64 0 {Helvetica 72} {}}
 266 test config-4.25 {DoObjConfig - invalid font} testobjconfig {
 267     catch {rename .foo {}}
 268     list [catch {testobjconfig alltypes .foo -font {Helvetica 12 foo}} msg] $msg
 269 } {1 {unknown font style "foo"}}
 270 test config-4.26 {DoObjConfig - null font} testobjconfig {
 271     catch {rename .foo {}}
 272     list [catch {testobjconfig alltypes .foo -font {}} msg] $msg [catch {.foo cget -font} result] $result [destroy .foo]
 273 } {0 .foo 0 {} {}}
 274 test config-4.27 {DoObjConfig - font internal value} testobjconfig {
 275     catch {rename .foo {}}
 276     testobjconfig internal .foo -font {Times 16}
 277     .foo cget -font
 278 } {Times 16}
 279 test config-4.28 {DoObjConfig - bitmap} testobjconfig {
 280     catch {destroy .foo}
 281     list [catch {testobjconfig alltypes .foo -bitmap gray75} msg] $msg [catch {.foo cget -bitmap} result] $result [destroy .foo]
 282 } {0 .foo 0 gray75 {}}
 283 test config-4.29 {DoObjConfig - new bitmap} testobjconfig {
 284     catch {destroy .foo}
 285     testobjconfig alltypes .foo -bitmap gray75
 286     list [catch {.foo configure -bitmap gray50} msg] $msg [catch {.foo cget -bitmap} result] $result [destroy .foo]
 287 } {0 128 0 gray50 {}}
 288 test config-4.30 {DoObjConfig - invalid bitmap} testobjconfig {
 289     catch {destroy .foo}
 290     list [catch {testobjconfig alltypes .foo -bitmap foo} msg] $msg
 291 } {1 {bitmap "foo" not defined}}
 292 test config-4.31 {DoObjConfig - null bitmap} testobjconfig {
 293     catch {destroy .foo}
 294     list [catch {testobjconfig alltypes .foo -bitmap {}} msg] $msg [catch {.foo cget -bitmap} result] $result [destroy .foo]
 295 } {0 .foo 0 {} {}}
 296 test config-4.32 {DoObjConfig - bitmap internal value} testobjconfig {
 297     catch {rename .foo {}}
 298     testobjconfig internal .foo -bitmap gray25
 299     .foo cget -bitmap
 300 } {gray25}
 301 test config-4.33 {DoObjConfig - border} testobjconfig {
 302     catch {rename .foo {}}
 303     list [catch {testobjconfig alltypes .foo -border green} msg] $msg [catch {.foo cget -border} result] $result [destroy .foo]
 304 } {0 .foo 0 green {}}
 305 test config-4.34 {DoObjConfig - invalid border} testobjconfig {
 306     catch {destroy .foo}
 307     list [catch {testobjconfig alltypes .foo -border xxx} msg] $msg
 308 } {1 {unknown color name "xxx"}}
 309 test config-4.35 {DoObjConfig - null border} testobjconfig {
 310     catch {rename .foo {}}
 311     list [catch {testobjconfig alltypes .foo -border {}} msg] $msg [catch {.foo cget -border} result] $result [destroy .foo]
 312 } {0 .foo 0 {} {}}
 313 test config-4.36 {DoObjConfig - border internal value} testobjconfig {
 314     catch {rename .foo {}}
 315     testobjconfig internal .foo -border #123456
 316     .foo cget -border
 317 } {#123456}
 318 test config-4.37 {DoObjConfig - getting rid of old border} testobjconfig {
 319     catch {destroy .foo}
 320     testobjconfig alltypes .foo -border #333333
 321     list [catch {.foo configure -border #444444} msg] $msg [catch {.foo cget -border} result] $result [destroy .foo]
 322 } {0 256 0 #444444 {}}
 323 test config-4.38 {DoObjConfig - relief} testobjconfig {
 324     catch {destroy .foo}
 325     list [catch {testobjconfig alltypes .foo -relief flat} msg] $msg [catch {.foo cget -relief} result] $result [destroy .foo]
 326 } {0 .foo 0 flat {}}
 327 test config-4.39 {DoObjConfig - invalid relief} testobjconfig {
 328     catch {destroy .foo}
 329     list [catch {testobjconfig alltypes .foo -relief foo} msg] $msg
 330 } {1 {bad relief "foo": must be flat, groove, raised, ridge, solid, or sunken}}
 331 test config-4.40 {DoObjConfig - new relief} testobjconfig {
 332     catch {destroy .foo}
 333     testobjconfig alltypes .foo -relief raised
 334     list [catch {.foo configure -relief flat} msg] $msg [catch {.foo cget -relief} result] $result [destroy .foo]
 335 } {0 512 0 flat {}}
 336 test config-4.41 {DoObjConfig - relief internal value} testobjconfig {
 337     catch {rename .foo {}}
 338     testobjconfig internal .foo -relief ridge
 339     .foo cget -relief
 340 } {ridge}
 341 test config-4.42 {DoObjConfig - cursor} testobjconfig {
 342     catch {destroy .foo}
 343     list [catch {testobjconfig alltypes .foo -cursor arrow} msg] $msg [catch {.foo cget -cursor} result] $result [destroy .foo]
 344 } {0 .foo 0 arrow {}}
 345 test config-4.43 {DoObjConfig - invalid cursor} testobjconfig {
 346     catch {destroy .foo}
 347     list [catch {testobjconfig alltypes .foo -cursor foo} msg] $msg
 348 } {1 {bad cursor spec "foo"}}
 349 test config-4.44 {DoObjConfig - null cursor} testobjconfig {
 350     catch {destroy .foo}
 351     list [catch {testobjconfig alltypes .foo -cursor {}} msg] $msg [catch {.foo cget -cursor} result] $result [destroy .foo]
 352 } {0 .foo 0 {} {}}
 353 test config-4.45 {DoObjConfig - new cursor} testobjconfig {
 354     catch {destroy .foo}
 355     testobjconfig alltypes .foo -cursor xterm
 356     list [catch {.foo configure -cursor arrow} msg] $msg [catch {.foo cget -cursor} result] $result [destroy .foo]
 357 } {0 1024 0 arrow {}}
 358 test config-4.46 {DoObjConfig - cursor internal value} testobjconfig {
 359     catch {rename .foo {}}
 360     testobjconfig internal .foo -cursor watch
 361     .foo cget -cursor
 362 } {watch}
 363 test config-4.47 {DoObjConfig - justify} testobjconfig {
 364     catch {destroy .foo}
 365     list [catch {testobjconfig alltypes .foo -justify center} msg] $msg [catch {.foo cget -justify} result] $result [destroy .foo]
 366 } {0 .foo 0 center {}}
 367 test config-4.48 {DoObjConfig - invalid justify} testobjconfig {
 368     catch {destroy .foo}
 369     list [catch {testobjconfig alltypes .foo -justify foo} msg] $msg
 370 } {1 {bad justification "foo": must be left, right, or center}}
 371 test config-4.49 {DoObjConfig - new justify} testobjconfig {
 372     catch {destroy .foo}
 373     testobjconfig alltypes .foo -justify left
 374     list [catch {.foo configure -justify right} msg] $msg [catch {.foo cget -justify} result] $result [destroy .foo]
 375 } {0 2048 0 right {}}
 376 test config-4.50 {DoObjConfig - justify internal value} testobjconfig {
 377     catch {rename .foo {}}
 378     testobjconfig internal .foo -justify center
 379     .foo cget -justify
 380 } {center}
 381 test config-4.51 {DoObjConfig - anchor} testobjconfig {
 382     catch {destroy .foo}
 383     list [catch {testobjconfig alltypes .foo -anchor center} msg] $msg [catch {.foo cget -anchor} result] $result [destroy .foo]
 384 } {0 .foo 0 center {}}
 385 test config-4.52 {DoObjConfig - invalid anchor} testobjconfig {
 386     catch {destroy .foo}
 387     list [catch {testobjconfig alltypes .foo -anchor foo} msg] $msg
 388 } {1 {bad anchor "foo": must be n, ne, e, se, s, sw, w, nw, or center}}
 389 test config-4.53 {DoObjConfig - new anchor} testobjconfig {
 390     catch {destroy .foo}
 391     testobjconfig alltypes .foo -anchor e
 392     list [catch {.foo configure -anchor n} msg] $msg [catch {.foo cget -anchor} result] $result [destroy .foo]
 393 } {0 4096 0 n {}}
 394 test config-4.54 {DoObjConfig - anchor internal value} testobjconfig {
 395     catch {rename .foo {}}
 396     testobjconfig internal .foo -anchor sw
 397     .foo cget -anchor
 398 } {sw}
 399 test config-4.55 {DoObjConfig - pixel} testobjconfig {
 400     catch {destroy .foo}
 401     list [catch {testobjconfig alltypes .foo -pixel 42} msg] $msg [catch {.foo cget -pixel} result] $result [destroy .foo]
 402 } {0 .foo 0 42 {}}
 403 test config-4.56 {DoObjConfig - invalid pixel} testobjconfig {
 404     catch {destroy .foo}
 405     list [catch {testobjconfig alltypes .foo -pixel foo} msg] $msg
 406 } {1 {bad screen distance "foo"}}
 407 test config-4.57 {DoObjConfig - new pixel} testobjconfig {
 408     catch {destroy .foo}
 409     testobjconfig alltypes .foo -pixel 42m
 410     list [catch {.foo configure -pixel 3c} msg] $msg [catch {.foo cget -pixel} result] $result [destroy .foo]
 411 } {0 8192 0 3c {}}
 412 test config-4.58 {DoObjConfig - pixel internal value} testobjconfig {
 413     catch {rename .foo {}}
 414     testobjconfig internal .foo -pixel [winfo screenmmwidth .]m
 415     .foo cget -pixel
 416 } [winfo screenwidth .]
 417 test config-4.59 {DoObjConfig - window} testobjconfig {
 418     catch {destroy .foo}
 419     catch {destroy .bar}
 420     toplevel .bar
 421     list [catch {testobjconfig twowindows .foo -window .bar} msg] $msg [catch {.foo cget -window} result] $result [destroy .foo] [destroy .bar]
 422 } {0 .foo 0 .bar {} {}}
 423 test config-4.60 {DoObjConfig - invalid window} testobjconfig {
 424     catch {destroy .foo}
 425     toplevel .bar
 426     list [catch {testobjconfig twowindows .foo -window foo} msg] $msg [destroy .bar]
 427 } {1 {bad window path name "foo"} {}}
 428 test config-4.61 {DoObjConfig - null window} testobjconfig {
 429     catch {destroy .foo}
 430     catch {destroy .bar}
 431     toplevel .bar
 432     list [catch {testobjconfig twowindows .foo -window {}} msg] $msg [catch {.foo cget -window} result] $result [destroy .foo]
 433 } {0 .foo 0 {} {}}
 434 test config-4.62 {DoObjConfig - new window} testobjconfig {
 435     catch {destroy .foo}
 436     catch {destroy .bar}
 437     catch {destroy .blamph}
 438     toplevel .bar
 439     toplevel .blamph
 440     testobjconfig twowindows .foo -window .bar
 441     list [catch {.foo configure -window .blamph} msg] $msg [catch {.foo cget -window} result] $result [destroy .foo] [destroy .bar] [destroy .blamph]
 442 } {0 0 0 .blamph {} {} {}}
 443 test config-4.63 {DoObjConfig - window internal value} testobjconfig {
 444     catch {rename .foo {}}
 445     testobjconfig internal .foo -window .
 446     .foo cget -window
 447 } {.}
 448 test config-4.64 {DoObjConfig - releasing old values} testobjconfig {
 449     # This test doesn't generate a useful value to check; if an
 450     # error occurs, it will be detected only by memory checking software
 451     # such as Purify or Tcl's built-in checker.
 452
 453     catch {rename .foo {}}
 454     testobjconfig alltypes .foo -string {Test string} -color yellow \
 455             -font {Courier 18} -bitmap questhead -border green -cursor cross \
 456             -custom foobar
 457     .foo configure -string {new string} -color brown \
 458             -font {Times 8} -bitmap gray75 -border pink -cursor watch \
 459             -custom barbaz
 460     concat {}
 461 } {}
 462 test config-4.65 {DoObjConfig - releasing old values} testobjconfig {
 463     # This test doesn't generate a useful value to check; if an
 464     # error occurs, it will be detected only by memory checking software
 465     # such as Purify or Tcl's built-in checker.
 466
 467     catch {rename .foo {}}
 468     testobjconfig internal .foo -string {Test string} -color yellow \
 469             -font {Courier 18} -bitmap questhead -border green -cursor cross \
 470             -custom foobar
 471     .foo configure -string {new string} -color brown \
 472             -font {Times 8} -bitmap gray75 -border pink -cursor watch \
 473             -custom barbaz
 474     concat {}
 475 } {}
 476 test config-4.66 {DoObjConfig - custom} testobjconfig {
 477     catch {destroy .foo}
 478     list [catch {testobjconfig alltypes .foo -custom test} msg] $msg [catch {.foo cget -custom} result] $result [destroy .foo]
 479 } {0 .foo 0 TEST {}}
 480 test config-4.67 {DoObjConfig - null custom} testobjconfig {
 481     catch {destroy .foo}
 482     list [catch {testobjconfig alltypes .foo -custom {}} msg] $msg [catch {.foo cget -custom} result] $result [destroy .foo]
 483 } {0 .foo 0 {} {}}
 484 test config-4.68 {DoObjConfig - custom internal value} testobjconfig {
 485     catch {rename .foo {}}
 486     testobjconfig internal .foo -custom "this is a test"
 487     .foo cget -custom
 488 } {THIS IS A TEST}
 489
 490 test config-5.1 {ObjectIsEmpty - object is already string} testobjconfig {
 491     catch {destroy .foo}
 492     testobjconfig alltypes .foo -color [format ""]
 493     .foo cget -color
 494 } {}
 495 test config-5.2 {ObjectIsEmpty - object is already string} testobjconfig {
 496     catch {destroy .foo}
 497     list [catch {testobjconfig alltypes .foo -color [format " "]} msg] $msg
 498 } {1 {unknown color name " "}}
 499 test config-5.3 {ObjectIsEmpty - must convert back to string} testobjconfig {
 500     catch {destroy .foo}
 501     testobjconfig alltypes .foo -color [list]
 502     .foo cget -color
 503 } {}
 504
 505 deleteWindows
 506 if {[testConstraint testobjconfig]} {
 507     testobjconfig chain2 .a
 508     testobjconfig alltypes .b
 509 }
 510 test config-6.1 {GetOptionFromObj - cached answer} testobjconfig {
 511     list [.a cget -three] [.a cget -three]
 512 } {three three}
 513 test config-6.2 {GetOptionFromObj - exact match} testobjconfig {
 514     .a cget -one
 515 } {one}
 516 test config-6.3 {GetOptionFromObj - abbreviation} testobjconfig {
 517     .a cget -fo
 518 } {four}
 519 test config-6.4 {GetOptionFromObj - ambiguous abbreviation} testobjconfig {
 520     list [catch {.a cget -on} msg] $msg
 521 } {1 {unknown option "-on"}}
 522 test config-6.5 {GetOptionFromObj - duplicate options in different tables} testobjconfig {
 523     .a cget -tw
 524 } {two and a half}
 525 test config-6.6 {GetOptionFromObj - synonym} testobjconfig {
 526     .b cget -synonym
 527 } {red}
 528
 529 deleteWindows
 530 if {[testConstraint testobjconfig]} {
 531     testobjconfig alltypes .a
 532 }
 533 test config-7.1 {Tk_SetOptions - basics} testobjconfig {
 534     .a configure -color green -rel sunken
 535      list [.a cget -color] [.a cget -relief]
 536 } {green sunken}
 537 test config-7.2 {Tk_SetOptions - bogus option name} testobjconfig {
 538     list [catch {.a configure -bogus} msg] $msg
 539 } {1 {unknown option "-bogus"}}
 540 test config-7.3 {Tk_SetOptions - synonym} testobjconfig {
 541     .a configure -synonym blue
 542     .a cget -color
 543 } {blue}
 544 test config-7.4 {Tk_SetOptions - missing value} testobjconfig {
 545     list [catch {.a configure -color green -relief} msg] $msg [.a cget -color]
 546 } {1 {value for "-relief" missing} green}
 547 test config-7.5 {Tk_SetOptions - saving old values} testobjconfig {
 548     .a configure -color red -int 7 -relief raised -double 3.14159
 549     list [catch {.a csave -color green -int 432 -relief sunken \
 550             -double 2.0 -color bogus} msg] $msg [.a cget -color] \
 551             [.a cget -int] [.a cget -relief] [.a cget -double]
 552 } {1 {unknown color name "bogus"} red 7 raised 3.14159}
 553 test config-7.6 {Tk_SetOptions - error in DoObjConfig call} testobjconfig {
 554     list [catch {.a configure -color bogus} msg] $msg $errorInfo
 555 } {1 {unknown color name "bogus"} {unknown color name "bogus"
 556     (processing "-color" option)
 557     invoked from within
 558 ".a configure -color bogus"}}
 559 test config-7.7 {Tk_SetOptions - synonym name in error message} testobjconfig {
 560     list [catch {.a configure -synonym bogus} msg] $msg $errorInfo
 561 } {1 {unknown color name "bogus"} {unknown color name "bogus"
 562     (processing "-synonym" option)
 563     invoked from within
 564 ".a configure -synonym bogus"}}
 565 test config-7.8 {Tk_SetOptions - returning mask} testobjconfig {
 566     format %x [.a configure -color red -int 7 -relief raised -double 3.14159]
 567 } {226}
 568 test config-7.9 {Tk_SetOptions - error in DoObjConfig with custom option} testobjconfig {
 569     list [catch {.a configure -custom bad} msg] $msg $errorInfo
 570 } {1 {expected good value, got "BAD"} {expected good value, got "BAD"
 571     (processing "-custom" option)
 572     invoked from within
 573 ".a configure -custom bad"}}
 574
 575 test config-8.1 {Tk_RestoreSavedOptions - restore in proper order} testobjconfig {
 576     deleteWindows
 577     testobjconfig alltypes .a
 578     list [catch {.a csave -color green -color black -color blue \
 579             -color #ffff00 -color #ff00ff -color bogus} msg] $msg \
 580             [.a cget -color]
 581 } {1 {unknown color name "bogus"} red}
 582 test config-8.2 {Tk_RestoreSavedOptions - freeing object memory} testobjconfig {
 583     deleteWindows
 584     testobjconfig alltypes .a
 585     .a csave -color green -color black -color blue -color #ffff00 \
 586             -color #ff00ff
 587 } {32}
 588 test config-8.3 {Tk_RestoreSavedOptions - boolean internal form} testobjconfig {
 589     deleteWindows
 590     testobjconfig internal .a
 591     list [catch {.a csave -boolean 0 -color bogus}] [.a cget -boolean]
 592 } {1 1}
 593 test config-8.4 {Tk_RestoreSavedOptions - integer internal form} testobjconfig {
 594     deleteWindows
 595     testobjconfig internal .a
 596     list [catch {.a csave -integer 24 -color bogus}] [.a cget -integer]
 597 } {1 148962237}
 598 test config-8.5 {Tk_RestoreSavedOptions - double internal form} testobjconfig {
 599     deleteWindows
 600     testobjconfig internal .a
 601     list [catch {.a csave -double 62.4 -color bogus}] [.a cget -double]
 602 } {1 3.14159}
 603 test config-8.6 {Tk_RestoreSavedOptions - string internal form} testobjconfig {
 604     deleteWindows
 605     testobjconfig internal .a
 606     list [catch {.a csave -string "A long string" -color bogus}] \
 607             [.a cget -string]
 608 } {1 foo}
 609 test config-8.7 {Tk_RestoreSavedOptions - string table internal form} testobjconfig {
 610     deleteWindows
 611     testobjconfig internal .a
 612     list [catch {.a csave -stringtable three -color bogus}] \
 613             [.a cget -stringtable]
 614 } {1 one}
 615 test config-8.8 {Tk_RestoreSavedOptions - color internal form} testobjconfig {
 616     deleteWindows
 617     testobjconfig internal .a
 618     list [catch {.a csave -color green -color bogus}] [.a cget -color]
 619 } {1 red}
 620 test config-8.9 {Tk_RestoreSavedOptions - font internal form} {testobjconfig nonPortable} {
 621     deleteWindows
 622     testobjconfig internal .a
 623     list [catch {.a csave -font {Times 12} -color bogus}] [.a cget -font]
 624 } {1 {Helvetica 12}}
 625 test config-8.10 {Tk_RestoreSavedOptions - bitmap internal form} testobjconfig {
 626     deleteWindows
 627     testobjconfig internal .a
 628     list [catch {.a csave -bitmap questhead -color bogus}] [.a cget -bitmap]
 629 } {1 gray50}
 630 test config-8.11 {Tk_RestoreSavedOptions - border internal form} testobjconfig {
 631     deleteWindows
 632     testobjconfig internal .a
 633     list [catch {.a csave -border brown -color bogus}] [.a cget -border]
 634 } {1 blue}
 635 test config-8.12 {Tk_RestoreSavedOptions - relief internal form} testobjconfig {
 636     deleteWindows
 637     testobjconfig internal .a
 638     list [catch {.a csave -relief sunken -color bogus}] [.a cget -relief]
 639 } {1 raised}
 640 test config-8.13 {Tk_RestoreSavedOptions - cursor internal form} testobjconfig {
 641     deleteWindows
 642     testobjconfig internal .a
 643     list [catch {.a csave -cursor watch -color bogus}] [.a cget -cursor]
 644 } {1 xterm}
 645 test config-8.14 {Tk_RestoreSavedOptions - justify internal form} testobjconfig {
 646     deleteWindows
 647     testobjconfig internal .a
 648     list [catch {.a csave -justify right -color bogus}] [.a cget -justify]
 649 } {1 left}
 650 test config-8.15 {Tk_RestoreSavedOptions - anchor internal form} testobjconfig {
 651     deleteWindows
 652     testobjconfig internal .a
 653     list [catch {.a csave -anchor center -color bogus}] [.a cget -anchor]
 654 } {1 n}
 655 test config-8.16 {Tk_RestoreSavedOptions - window internal form} testobjconfig {
 656     deleteWindows
 657     testobjconfig internal .a -window .a
 658     list [catch {.a csave -window .a -color bogus}] [.a cget -window]
 659 } {1 .a}
 660 test config-8.17 {Tk_RestoreSavedOptions - custom internal form} testobjconfig {
 661     deleteWindows
 662     testobjconfig internal .a -custom "foobar"
 663     list [catch {.a csave -custom "barbaz" -color bogus}] [.a cget -custom]
 664 } {1 FOOBAR}
 665
 666 # Most of the tests below will cause memory leakage if there is a
 667 # problem.  This may not be evident unless the tests are run in
 668 # conjunction with a memory usage analyzer such as Purify.
 669
 670 test config-9.1 {Tk_FreeConfigOptions/FreeResources - string internal form} testobjconfig {
 671     catch {destroy .foo}
 672     testobjconfig internal .foo
 673     .foo configure -string "two words"
 674     destroy .foo
 675 } {}
 676 test config-9.2 {Tk_FreeConfigOptions/FreeResources - color internal form} testobjconfig {
 677     catch {destroy .foo}
 678     testobjconfig internal .foo
 679     .foo configure -color yellow
 680     destroy .foo
 681 } {}
 682 test config-9.3 {Tk_FreeConfigOptions/FreeResources - color} testobjconfig {
 683     catch {destroy .foo}
 684     testobjconfig alltypes .foo
 685     .foo configure -color [format blue]
 686     destroy .foo
 687 } {}
 688 test config-9.4 {Tk_FreeConfigOptions/FreeResources - font internal form} testobjconfig {
 689     catch {destroy .foo}
 690     testobjconfig internal .foo
 691     .foo configure -font {Courier 20}
 692     destroy .foo
 693 } {}
 694 test config-9.5 {Tk_FreeConfigOptions/FreeResources - font} testobjconfig {
 695     catch {destroy .foo}
 696     testobjconfig alltypes .foo
 697     .foo configure -font [format {Courier 24}]
 698     destroy .foo
 699 } {}
 700 test config-9.6 {Tk_FreeConfigOptions/FreeResources - bitmap internal form} testobjconfig {
 701     catch {destroy .foo}
 702     testobjconfig internal .foo
 703     .foo configure -bitmap gray75
 704     destroy .foo
 705 } {}
 706 test config-9.7 {Tk_FreeConfigOptions/FreeResources - bitmap} testobjconfig {
 707     catch {destroy .foo}
 708     testobjconfig alltypes .foo
 709     .foo configure -bitmap [format gray75]
 710     destroy .foo
 711 } {}
 712 test config-9.8 {Tk_FreeConfigOptions/FreeResources - border internal form} testobjconfig {
 713     catch {destroy .foo}
 714     testobjconfig internal .foo
 715     .foo configure -border orange
 716     destroy .foo
 717 } {}
 718 test config-9.9 {Tk_FreeConfigOptions/FreeResources - border} testobjconfig {
 719     catch {destroy .foo}
 720     testobjconfig alltypes .foo
 721     .foo configure -border [format blue]
 722     destroy .foo
 723 } {}
 724 test config-9.10 {Tk_FreeConfigOptions/FreeResources - cursor internal form} testobjconfig {
 725     catch {destroy .foo}
 726     testobjconfig internal .foo
 727     .foo configure -cursor cross
 728     destroy .foo
 729 } {}
 730 test config-9.11 {Tk_FreeConfigOptions/FreeResources - cursor} testobjconfig {
 731     catch {destroy .foo}
 732     testobjconfig alltypes .foo
 733     .foo configure -cursor [format watch]
 734     destroy .foo
 735 } {}
 736 test config-9.12 {Tk_FreeConfigOptions/FreeResources - not special} testobjconfig {
 737     catch {destroy .foo}
 738     testobjconfig alltypes .foo
 739     .foo configure -integer [format 27]
 740     destroy .foo
 741 } {}
 742 test config-9.13 {Tk_FreeConfigOptions/FreeResources - custom internal form} testobjconfig {
 743     catch {destroy .fpp}
 744     testobjconfig internal .foo
 745     .foo configure -custom "foobar"
 746     destroy .foo
 747 } {}
 748
 749 test config-10.1 {Tk_GetOptionInfo - one item} testobjconfig {
 750     catch {destroy .foo}
 751     testobjconfig alltypes .foo
 752     .foo configure -relief groove
 753     .foo configure -relief
 754 } {-relief relief Relief raised groove}
 755 test config-10.2 {Tk_GetOptionInfo - one item, synonym} testobjconfig {
 756     catch {destroy .foo}
 757     testobjconfig alltypes .foo
 758     .foo configure -color black
 759     .foo configure -synonym
 760 } {-color color Color red black}
 761 test config-10.3 {Tk_GetOptionInfo - all items} testobjconfig {
 762     catch {destroy .foo}
 763     testobjconfig alltypes .foo -font {Helvetica 18} -integer 13563
 764     .foo configure
 765 } {{-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}}
 766 test config-10.4 {Tk_GetOptionInfo - chaining through tables} testobjconfig {
 767     catch {destroy .foo}
 768     testobjconfig chain2 .foo -one asdf -three xyzzy
 769     .foo configure
 770 } {{-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}}}
 771
 772 deleteWindows
 773 if {[testConstraint testobjconfig]} {
 774     testobjconfig alltypes .a
 775 }
 776 test config-11.1 {GetConfigList - synonym} testobjconfig {
 777     lindex [.a configure] end
 778 } {-synonym -color}
 779 test config-11.2 {GetConfigList - null database names} testobjconfig {
 780     .a configure -justify
 781 } {-justify {} {} left left}
 782 test config-11.3 {GetConfigList - null default and current value} testobjconfig {
 783     .a configure -anchor
 784 } {-anchor anchor Anchor {} {}}
 785
 786 deleteWindows
 787 if {[testConstraint testobjconfig]} {
 788     testobjconfig internal .a
 789 }
 790 test config-12.1 {GetObjectForOption - boolean} testobjconfig {
 791     .a configure -boolean 0
 792     .a cget -boolean
 793 } {0}
 794 test config-12.2 {GetObjectForOption - integer} testobjconfig {
 795     .a configure -integer 1247
 796     .a cget -integer
 797 } {1247}
 798 test config-12.3 {GetObjectForOption - double} testobjconfig {
 799     .a configure -double -88.82
 800     .a cget -double
 801 } {-88.82}
 802 test config-12.4 {GetObjectForOption - string} testobjconfig {
 803     .a configure -string "test value"
 804     .a cget -string
 805 } {test value}
 806 test config-12.5 {GetObjectForOption - stringTable} testobjconfig {
 807     .a configure -stringtable "two"
 808     .a cget -stringtable
 809 } {two}
 810 test config-12.6 {GetObjectForOption - color} testobjconfig {
 811     .a configure -color "green"
 812     .a cget -color
 813 } {green}
 814 test config-12.7 {GetObjectForOption - font} testobjconfig {
 815     .a configure -font {Times 36}
 816     .a cget -font
 817 } {Times 36}
 818 test config-12.8 {GetObjectForOption - bitmap} testobjconfig {
 819     .a configure -bitmap "questhead"
 820     .a cget -bitmap
 821 } {questhead}
 822 test config-12.9 {GetObjectForOption - border} testobjconfig {
 823     .a configure -border #33217c
 824     .a cget -border
 825 } {#33217c}
 826 test config-12.10 {GetObjectForOption - relief} testobjconfig {
 827     .a configure -relief groove
 828     .a cget -relief
 829 } {groove}
 830 test config-12.11 {GetObjectForOption - cursor} testobjconfig {
 831     .a configure -cursor watch
 832     .a cget -cursor
 833 } {watch}
 834 test config-12.12 {GetObjectForOption - justify} testobjconfig {
 835     .a configure -justify right
 836     .a cget -justify
 837 } {right}
 838 test config-12.13 {GetObjectForOption - anchor} testobjconfig {
 839     .a configure -anchor e
 840     .a cget -anchor
 841 } {e}
 842 test config-12.14 {GetObjectForOption - pixels} testobjconfig {
 843     .a configure -pixel 193.2
 844     .a cget -pixel
 845 } {193}
 846 test config-12.15 {GetObjectForOption - window} testobjconfig {
 847     .a configure -window .a
 848     .a cget -window
 849 } {.a}
 850 test config-12.16 {GetObjectForOption -custom} testobjconfig {
 851     .a configure -custom foobar
 852     .a cget -custom
 853 } {FOOBAR}
 854 test config-12.17 {GetObjectForOption - null values} testobjconfig {
 855     .a configure -string {} -color {} -font {} -bitmap {} -border {} \
 856             -cursor {} -window {} -custom {}
 857     list [.a cget -string] [.a cget -color] [.a cget -font] \
 858             [.a cget -bitmap] [.a cget -border] [.a cget -cursor] \
 859             [.a cget -window] [.a cget -custom]
 860 } {{} {} {} {} {} {} {} {}}
 861
 862 test config-13.1 {proper cleanup of options with widget destroy} {
 863     foreach type {
 864         button canvas entry frame listbox menu menubutton message
 865         scale scrollbar text radiobutton checkbutton
 866     } {
 867         destroy .w
 868         $type .w -cursor crosshair
 869         destroy .w
 870     }
 871 } {}
 872
 873 deleteWindows
 874
 875 test config-14.1 {Tk_CreateOptionTable - use with namespace import} {
 876     namespace export -clear *
 877     foreach type {
 878         button canvas entry frame listbox menu menubutton message
 879         scale scrollbar spinbox text radiobutton checkbutton
 880     } {
 881         namespace eval ::foo [subst {
 882             namespace import -force ::$type
 883             ::foo::$type .a
 884             ::foo::$type .b
 885         }
 886         ]
 887         destroy .a .b
 888     }
 889 } {}
 890
 891 # cleanup
 892 deleteWindows
 893 if {[testConstraint testobjconfig]} {
 894     killTables
 895 }
 896 ::tcltest::cleanupTests
 897 return