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: config.test,v 1.6 2002/07/14 05:48:46 dgp Exp $ 10 11package require tcltest 2.1 12namespace import -force tcltest::configure 13namespace import -force tcltest::testsDirectory 14configure -testdir [file join [pwd] [file dirname [info script]]] 15configure -loadfile [file join [testsDirectory] constraints.tcl] 16tcltest::loadTestedCommands 17 18testConstraint testobjconfig [llength [info commands testobjconfig]] 19 20proc 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 33if {[testConstraint testobjconfig]} { 34 killTables 35} 36 37test 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}} 48test config-1.2 {Tk_CreateOptionTable - synonym initialization} testobjconfig { 49 deleteWindows 50 testobjconfig alltypes .a -synonym green 51 .a cget -color 52} {green} 53test 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} 61test 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} 69test config-1.5 {Tk_CreateOptionTable - default initialization} testobjconfig { 70 deleteWindows 71 testobjconfig alltypes .a 72 .a cget -relief 73} {raised} 74test 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} 81test 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} 88test 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 96test 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 112test 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}} 118test 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} 125test 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} 132test config-3.4 {Tk_InitOptions - initialize from widget class} testobjconfig { 133 deleteWindows 134 testobjconfig alltypes .a 135 list [.a cget -color] 136} {red} 137test config-3.5 {Tk_InitOptions - no initial value} testobjconfig { 138 deleteWindows 139 testobjconfig alltypes .a 140 .a cget -anchor 141} {} 142test 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"}} 151option clear 152test 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"}} 159option clear 160 161test 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} 165test 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} 169test 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 ""}} 173test config-4.4 {DoObjConfig - boolean internal value} testobjconfig { 174 catch {rename .foo {}} 175 testobjconfig internal .foo -boolean 0 176 .foo cget -boolean 177} {0} 178test 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} 182test 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"}} 186test config-4.7 {DoObjConfig - integer internal value} testobjconfig { 187 catch {rename .foo {}} 188 testobjconfig internal .foo -integer 421 189 .foo cget -integer 190} {421} 191test 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} 195test 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"}} 199test 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} 204test 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 {}} 208test 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 {} {}} 212test 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} 217test 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 {}} 221test 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}} 225test 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 {}} 230test config-4.17 {DoObjConfig - stringtable internal value} testobjconfig { 231 catch {rename .foo {}} 232 testobjconfig internal .foo -stringtable "four" 233 .foo cget -stringtable 234} {four} 235test 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 {}} 239test 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"}} 243test config-4.20 {DoObjConfig - color internal value} testobjconfig { 244 catch {rename .foo {}} 245 testobjconfig internal .foo -color purple 246 .foo cget -color 247} {purple} 248test 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 {} {}} 252test 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 {}} 257test 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} {}} 261test 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} {}} 266test 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"}} 270test 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 {} {}} 274test 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} 279test 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 {}} 283test 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 {}} 288test 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}} 292test 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 {} {}} 296test config-4.32 {DoObjConfig - bitmap internal value} testobjconfig { 297 catch {rename .foo {}} 298 testobjconfig internal .foo -bitmap gray25 299 .foo cget -bitmap 300} {gray25} 301test 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 {}} 305test 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"}} 309test 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 {} {}} 313test config-4.36 {DoObjConfig - border internal value} testobjconfig { 314 catch {rename .foo {}} 315 testobjconfig internal .foo -border #123456 316 .foo cget -border 317} {#123456} 318test 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 {}} 323test 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 {}} 327test 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}} 331test 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 {}} 336test config-4.41 {DoObjConfig - relief internal value} testobjconfig { 337 catch {rename .foo {}} 338 testobjconfig internal .foo -relief ridge 339 .foo cget -relief 340} {ridge} 341test 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 {}} 345test 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"}} 349test 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 {} {}} 353test 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 {}} 358test config-4.46 {DoObjConfig - cursor internal value} testobjconfig { 359 catch {rename .foo {}} 360 testobjconfig internal .foo -cursor watch 361 .foo cget -cursor 362} {watch} 363test 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 {}} 367test 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}} 371test 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 {}} 376test config-4.50 {DoObjConfig - justify internal value} testobjconfig { 377 catch {rename .foo {}} 378 testobjconfig internal .foo -justify center 379 .foo cget -justify 380} {center} 381test 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 {}} 385test 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}} 389test 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 {}} 394test config-4.54 {DoObjConfig - anchor internal value} testobjconfig { 395 catch {rename .foo {}} 396 testobjconfig internal .foo -anchor sw 397 .foo cget -anchor 398} {sw} 399test 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 {}} 403test 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"}} 407test 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 {}} 412test 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 .] 417test 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 {} {}} 423test 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"} {}} 428test 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 {} {}} 434test 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 {} {} {}} 443test config-4.63 {DoObjConfig - window internal value} testobjconfig { 444 catch {rename .foo {}} 445 testobjconfig internal .foo -window . 446 .foo cget -window 447} {.} 448test 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} {} 462test 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} {} 476test 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 {}} 480test 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 {} {}} 484test 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 490test config-5.1 {ObjectIsEmpty - object is already string} testobjconfig { 491 catch {destroy .foo} 492 testobjconfig alltypes .foo -color [format ""] 493 .foo cget -color 494} {} 495test 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 " "}} 499test 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 505deleteWindows 506if {[testConstraint testobjconfig]} { 507 testobjconfig chain2 .a 508 testobjconfig alltypes .b 509} 510test config-6.1 {GetOptionFromObj - cached answer} testobjconfig { 511 list [.a cget -three] [.a cget -three] 512} {three three} 513test config-6.2 {GetOptionFromObj - exact match} testobjconfig { 514 .a cget -one 515} {one} 516test config-6.3 {GetOptionFromObj - abbreviation} testobjconfig { 517 .a cget -fo 518} {four} 519test config-6.4 {GetOptionFromObj - ambiguous abbreviation} testobjconfig { 520 list [catch {.a cget -on} msg] $msg 521} {1 {unknown option "-on"}} 522test config-6.5 {GetOptionFromObj - duplicate options in different tables} testobjconfig { 523 .a cget -tw 524} {two and a half} 525test config-6.6 {GetOptionFromObj - synonym} testobjconfig { 526 .b cget -synonym 527} {red} 528 529deleteWindows 530if {[testConstraint testobjconfig]} { 531 testobjconfig alltypes .a 532} 533test 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} 537test config-7.2 {Tk_SetOptions - bogus option name} testobjconfig { 538 list [catch {.a configure -bogus} msg] $msg 539} {1 {unknown option "-bogus"}} 540test config-7.3 {Tk_SetOptions - synonym} testobjconfig { 541 .a configure -synonym blue 542 .a cget -color 543} {blue} 544test 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} 547test 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} 553test 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"}} 559test 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"}} 565test config-7.8 {Tk_SetOptions - returning mask} testobjconfig { 566 format %x [.a configure -color red -int 7 -relief raised -double 3.14159] 567} {226} 568test 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 575test 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} 582test 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} 588test 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} 593test 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} 598test 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} 603test 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} 609test 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} 615test 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} 620test 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}} 625test 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} 630test 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} 635test 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} 640test 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} 645test 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} 650test 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} 655test 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} 660test 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 670test 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} {} 676test 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} {} 682test 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} {} 688test 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} {} 694test 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} {} 700test 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} {} 706test 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} {} 712test 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} {} 718test 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} {} 724test 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} {} 730test 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} {} 736test 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} {} 742test 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 749test 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} 755test 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} 761test 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}} 766test 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 772deleteWindows 773if {[testConstraint testobjconfig]} { 774 testobjconfig alltypes .a 775} 776test config-11.1 {GetConfigList - synonym} testobjconfig { 777 lindex [.a configure] end 778} {-synonym -color} 779test config-11.2 {GetConfigList - null database names} testobjconfig { 780 .a configure -justify 781} {-justify {} {} left left} 782test config-11.3 {GetConfigList - null default and current value} testobjconfig { 783 .a configure -anchor 784} {-anchor anchor Anchor {} {}} 785 786deleteWindows 787if {[testConstraint testobjconfig]} { 788 testobjconfig internal .a 789} 790test config-12.1 {GetObjectForOption - boolean} testobjconfig { 791 .a configure -boolean 0 792 .a cget -boolean 793} {0} 794test config-12.2 {GetObjectForOption - integer} testobjconfig { 795 .a configure -integer 1247 796 .a cget -integer 797} {1247} 798test config-12.3 {GetObjectForOption - double} testobjconfig { 799 .a configure -double -88.82 800 .a cget -double 801} {-88.82} 802test config-12.4 {GetObjectForOption - string} testobjconfig { 803 .a configure -string "test value" 804 .a cget -string 805} {test value} 806test config-12.5 {GetObjectForOption - stringTable} testobjconfig { 807 .a configure -stringtable "two" 808 .a cget -stringtable 809} {two} 810test config-12.6 {GetObjectForOption - color} testobjconfig { 811 .a configure -color "green" 812 .a cget -color 813} {green} 814test config-12.7 {GetObjectForOption - font} testobjconfig { 815 .a configure -font {Times 36} 816 .a cget -font 817} {Times 36} 818test config-12.8 {GetObjectForOption - bitmap} testobjconfig { 819 .a configure -bitmap "questhead" 820 .a cget -bitmap 821} {questhead} 822test config-12.9 {GetObjectForOption - border} testobjconfig { 823 .a configure -border #33217c 824 .a cget -border 825} {#33217c} 826test config-12.10 {GetObjectForOption - relief} testobjconfig { 827 .a configure -relief groove 828 .a cget -relief 829} {groove} 830test config-12.11 {GetObjectForOption - cursor} testobjconfig { 831 .a configure -cursor watch 832 .a cget -cursor 833} {watch} 834test config-12.12 {GetObjectForOption - justify} testobjconfig { 835 .a configure -justify right 836 .a cget -justify 837} {right} 838test config-12.13 {GetObjectForOption - anchor} testobjconfig { 839 .a configure -anchor e 840 .a cget -anchor 841} {e} 842test config-12.14 {GetObjectForOption - pixels} testobjconfig { 843 .a configure -pixel 193.2 844 .a cget -pixel 845} {193} 846test config-12.15 {GetObjectForOption - window} testobjconfig { 847 .a configure -window .a 848 .a cget -window 849} {.a} 850test config-12.16 {GetObjectForOption -custom} testobjconfig { 851 .a configure -custom foobar 852 .a cget -custom 853} {FOOBAR} 854test 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 862test 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 873deleteWindows 874 875test 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 892deleteWindows 893if {[testConstraint testobjconfig]} { 894 killTables 895} 896::tcltest::cleanupTests 897return 898