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