1# This file is a Tcl script to test out the "frame" and "toplevel" 2# commands of Tk. It is organized in the standard fashion for Tcl 3# tests. 4# 5# Copyright (c) 1994 The Regents of the University of California. 6# Copyright (c) 1994-1996 Sun Microsystems, Inc. 7# Copyright (c) 1998-1999 by Scriptics Corporation. 8# All rights reserved. 9# 10# RCS: @(#) $Id: frame.test,v 1.7.2.1 2003/07/16 23:17:39 pspjuth Exp $ 11 12package require tcltest 2.1 13namespace import -force tcltest::configure 14namespace import -force tcltest::testsDirectory 15configure -testdir [file join [pwd] [file dirname [info script]]] 16configure -loadfile [file join [testsDirectory] constraints.tcl] 17tcltest::loadTestedCommands 18 19# eatColors -- 20# Creates a toplevel window and allocates enough colors in it to 21# use up all the slots in the colormap. 22# 23# Arguments: 24# w - Name of toplevel window to create. 25 26proc eatColors {w} { 27 catch {destroy $w} 28 toplevel $w 29 wm geom $w +0+0 30 canvas $w.c -width 400 -height 200 -bd 0 31 pack $w.c 32 for {set y 0} {$y < 8} {incr y} { 33 for {set x 0} {$x < 40} {incr x} { 34 set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0] 35 $w.c create rectangle [expr 10*$x] [expr 20*$y] \ 36 [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \ 37 -fill $color 38 } 39 } 40 update 41} 42 43# colorsFree -- 44# 45# Returns 1 if there appear to be free colormap entries in a window, 46# 0 otherwise. 47# 48# Arguments: 49# w - Name of window in which to check. 50# red, green, blue - Intensities to use in a trial color allocation 51# to see if there are colormap entries free. 52 53proc colorsFree {w {red 31} {green 245} {blue 192}} { 54 set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]] 55 expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \ 56 && ([lindex $vals 2]/256 == $blue) 57} 58 59test frame-1.1 {frame configuration options} { 60 frame .f -class NewFrame 61 list [.f configure -class] [catch {.f configure -class Different} msg] $msg 62} {{-class class Class Frame NewFrame} 1 {can't modify -class option after widget is created}} 63catch {destroy .f} 64test frame-1.2 {frame configuration options} { 65 frame .f -colormap new 66 list [.f configure -colormap] [catch {.f configure -colormap .} msg] $msg 67} {{-colormap colormap Colormap {} new} 1 {can't modify -colormap option after widget is created}} 68catch {destroy .f} 69test frame-1.3 {frame configuration options} { 70 frame .f -visual default 71 list [.f configure -visual] [catch {.f configure -visual best} msg] $msg 72} {{-visual visual Visual {} default} 1 {can't modify -visual option after widget is created}} 73catch {destroy .f} 74test frame-1.4 {frame configuration options} { 75 list [catch {frame .f -screen bogus} msg] $msg 76} {1 {unknown option "-screen"}} 77test frame-1.5 {frame configuration options} { 78 set result [list [catch {frame .f -container true} msg] $msg \ 79 [.f configure -container]] 80 destroy .f 81 set result 82} {0 .f {-container container Container 0 1}} 83test frame-1.6 {frame configuration options} { 84 list [catch {frame .f -container bogus} msg] $msg 85} {1 {expected boolean value but got "bogus"}} 86test frame-1.7 {frame configuration options} { 87 frame .f 88 set result [list [catch {.f configure -container 1} msg] $msg] 89 destroy .f 90 set result 91} {1 {can't modify -container option after widget is created}} 92test frame-1.8 {frame configuration options} { 93 # Make sure all options can be set to the default value 94 frame .f 95 set opts {} 96 foreach opt [.f configure] { 97 if {[llength $opt] == 5} { 98 lappend opts [lindex $opt 0] [lindex $opt 4] 99 } 100 } 101 eval frame .g $opts 102 destroy .f .g 103} {} 104 105frame .f 106set i 9 107foreach test { 108 {-background #ff0000 #ff0000 non-existent 109 {unknown color name "non-existent"}} 110 {-bd 4 4 badValue {bad screen distance "badValue"}} 111 {-bg #00ff00 #00ff00 non-existent 112 {unknown color name "non-existent"}} 113 {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} 114 {-cursor arrow arrow badValue {bad cursor spec "badValue"}} 115 {-height 100 100 not_a_number {bad screen distance "not_a_number"}} 116 {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} 117 {-highlightcolor #123456 #123456 non-existent 118 {unknown color name "non-existent"}} 119 {-highlightthickness 6 6 badValue {bad screen distance "badValue"}} 120 {-padx 3 3 badValue {bad screen distance "badValue"}} 121 {-pady 4 4 badValue {bad screen distance "badValue"}} 122 {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}} 123 {-takefocus "any string" "any string" {} {}} 124 {-width 32 32 badValue {bad screen distance "badValue"}} 125} { 126 set name [lindex $test 0] 127 test frame-1.$i {frame configuration options} { 128 .f configure $name [lindex $test 1] 129 lindex [.f configure $name] 4 130 } [lindex $test 2] 131 incr i 132 if {[lindex $test 3] != ""} { 133 test frame-1.$i {frame configuration options} { 134 list [catch {.f configure $name [lindex $test 3]} msg] $msg 135 } [list 1 [lindex $test 4]] 136 } 137 .f configure $name [lindex [.f configure $name] 3] 138 incr i 139} 140destroy .f 141 142set i 1 143test frame-2.1 {toplevel configuration options} { 144 catch {destroy .t} 145 toplevel .t -width 200 -height 100 -class NewClass 146 wm geometry .t +0+0 147 list [.t configure -class] [catch {.t configure -class Another} msg] $msg 148} {{-class class Class Toplevel NewClass} 1 {can't modify -class option after widget is created}} 149test frame-2.2 {toplevel configuration options} { 150 catch {destroy .t} 151 toplevel .t -width 200 -height 100 -colormap new 152 wm geometry .t +0+0 153 list [.t configure -colormap] [catch {.t configure -colormap .} msg] $msg 154} {{-colormap colormap Colormap {} new} 1 {can't modify -colormap option after widget is created}} 155test frame-2.3 {toplevel configuration options} { 156 catch {destroy .t} 157 toplevel .t -width 200 -height 100 -colormap {} -use {} 158 wm geometry .t +0+0 159 list [catch {.t configure -container 1} msg] $msg [.t configure -container] 160} {1 {can't modify -container option after widget is created} {-container container Container 0 0}} 161test frame-2.4 {toplevel configuration options} { 162 catch {destroy .t} 163 list [catch {toplevel .t -width 200 -height 100 -colormap bogus} msg] $msg 164} {1 {bad window path name "bogus"}} 165set default "[winfo visual .] [winfo depth .]" 166test frame-2.5 {toplevel configuration options} { 167 catch {destroy .t} 168 toplevel .t -width 200 -height 100 169 wm geometry .t +0+0 170 list [catch {.t configure -use 0x44022} msg] $msg [.t configure -use] 171} {1 {can't modify -use option after widget is created} {-use use Use {} {}}} 172test frame-2.6 {toplevel configuration options} { 173 catch {destroy .t} 174 toplevel .t -width 200 -height 100 -visual default 175 wm geometry .t +0+0 176 list [.t configure -visual] [catch {.t configure -visual best} msg] $msg 177} {{-visual visual Visual {} default} 1 {can't modify -visual option after widget is created}} 178test frame-2.7 {toplevel configuration options} { 179 catch {destroy .t} 180 list [catch {toplevel .t -width 200 -height 100 -visual who_knows?} msg] $msg 181} {1 {unknown or ambiguous visual name "who_knows?": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}} 182if [info exists env(DISPLAY)] { 183 test frame-2.8 {toplevel configuration options} { 184 catch {destroy .t} 185 toplevel .t -width 200 -height 100 -screen $env(DISPLAY) 186 wm geometry .t +0+0 187 list [.t configure -screen] \ 188 [catch {.t configure -screen another} msg] $msg 189 } [list [list -screen screen Screen {} $env(DISPLAY)] 1 {can't modify -screen option after widget is created}] 190} 191test frame-2.9 {toplevel configuration options} { 192 catch {destroy .t} 193 list [catch {toplevel .t -width 200 -height 100 -screen bogus} msg] $msg 194} {1 {couldn't connect to display "bogus"}} 195test frame-2.10 {toplevel configuration options} { 196 catch {destroy .t} 197 catch {destroy .x} 198 toplevel .t -container 1 -width 300 -height 120 199 wm geometry .t +0+0 200 set result [list \ 201 [catch {toplevel .x -container 1 -use [winfo id .t]} msg] $msg] 202 destroy .t .x 203 set result 204} {1 {A window cannot have both the -use and the -container option set.}} 205test frame-2.11 {toplevel configuration options} { 206 # Make sure all options can be set to the default value 207 toplevel .f 208 set opts {} 209 foreach opt [.f configure] { 210 if {[llength $opt] == 5} { 211 lappend opts [lindex $opt 0] [lindex $opt 4] 212 } 213 } 214 eval toplevel .g $opts 215 destroy .f .g 216} {} 217 218catch {destroy .t} 219toplevel .t -width 300 -height 150 220wm geometry .t +0+0 221update 222set i 12 223foreach test { 224 {-background #ff0000 #ff0000 non-existent 225 {unknown color name "non-existent"}} 226 {-bd 4 4 badValue {bad screen distance "badValue"}} 227 {-bg #00ff00 #00ff00 non-existent 228 {unknown color name "non-existent"}} 229 {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} 230 {-cursor arrow arrow badValue {bad cursor spec "badValue"}} 231 {-height 100 100 not_a_number {bad screen distance "not_a_number"}} 232 {-highlightcolor #123456 #123456 non-existent 233 {unknown color name "non-existent"}} 234 {-highlightthickness 3 3 badValue {bad screen distance "badValue"}} 235 {-padx 3 3 badValue {bad screen distance "badValue"}} 236 {-pady 4 4 badValue {bad screen distance "badValue"}} 237 {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}} 238 {-width 32 32 badValue {bad screen distance "badValue"}} 239} { 240 set name [lindex $test 0] 241 test frame-2.$i {toplevel configuration options} { 242 .t configure $name [lindex $test 1] 243 lindex [.t configure $name] 4 244 } [lindex $test 2] 245 incr i 246 if {[lindex $test 3] != ""} { 247 test frame-2.$i {toplevel configuration options} { 248 list [catch {.t configure $name [lindex $test 3]} msg] $msg 249 } [list 1 [lindex $test 4]] 250 } 251 .t configure $name [lindex [.t configure $name] 3] 252 incr i 253} 254 255test frame-3.1 {TkCreateFrame procedure} { 256 list [catch frame msg] $msg 257} {1 {wrong # args: should be "frame pathName ?options?"}} 258test frame-3.2 {TkCreateFrame procedure} { 259 catch {destroy .f} 260 frame .f 261 set result [.f configure -class] 262 destroy .f 263 set result 264} {-class class Class Frame Frame} 265test frame-3.3 {TkCreateFrame procedure} { 266 catch {destroy .t} 267 toplevel .t 268 wm geometry .t +0+0 269 set result [.t configure -class] 270 destroy .t 271 set result 272} {-class class Class Toplevel Toplevel} 273test frame-3.4 {TkCreateFrame procedure} { 274 catch {destroy .t} 275 toplevel .t -width 350 -class NewClass -bg black -visual default -height 90 276 wm geometry .t +0+0 277 update 278 list [lindex [.t configure -width] 4] \ 279 [lindex [.t configure -background] 4] \ 280 [lindex [.t configure -height] 4] 281} {350 black 90} 282 283# Be sure that the -class, -colormap, and -visual options are processed 284# before configuring the widget. 285 286test frame-3.5 {TkCreateFrame procedure} { 287 catch {destroy .f} 288 option add *NewFrame.background #123456 289 frame .f -class NewFrame 290 option clear 291 lindex [.f configure -background] 4 292} {#123456} 293test frame-3.6 {TkCreateFrame procedure} { 294 catch {destroy .f} 295 option add *NewFrame.background #123456 296 frame .f -class NewFrame 297 option clear 298 lindex [.f configure -background] 4 299} {#123456} 300test frame-3.7 {TkCreateFrame procedure} { 301 catch {destroy .f} 302 option add *NewFrame.background #332211 303 option add *f.class NewFrame 304 frame .f 305 option clear 306 list [lindex [.f configure -class] 4] [lindex [.f configure -background] 4] 307} {NewFrame #332211} 308test frame-3.8 {TkCreateFrame procedure} { 309 catch {destroy .f} 310 option add *Silly.background #122334 311 option add *f.Class Silly 312 frame .f 313 option clear 314 list [lindex [.f configure -class] 4] [lindex [.f configure -background] 4] 315} {Silly #122334} 316test frame-3.9 {TkCreateFrame procedure, -use option} unixOnly { 317 catch {destroy .t} 318 catch {destroy .x} 319 toplevel .t -container 1 -width 300 -height 120 320 wm geometry .t +0+0 321 toplevel .x -width 140 -height 300 -use [winfo id .t] -bg green 322 tkwait visibility .x 323 set result "[expr [winfo rootx .x] - [winfo rootx .t]] [expr [winfo rooty .x] - [winfo rooty .t]] [winfo width .t] [winfo height .t]" 324 destroy .t 325 set result 326} {0 0 140 300} 327test frame-3.10 {TkCreateFrame procedure, -use option} unixOnly { 328 catch {destroy .t} 329 catch {destroy .x} 330 toplevel .t -container 1 -width 300 -height 120 331 wm geometry .t +0+0 332 option add *x.use [winfo id .t] 333 toplevel .x -width 140 -height 300 -bg green 334 tkwait visibility .x 335 set result "[expr [winfo rootx .x] - [winfo rootx .t]] [expr [winfo rooty .x] - [winfo rooty .t]] [winfo width .t] [winfo height .t]" 336 destroy .t 337 option clear 338 set result 339} {0 0 140 300} 340 341# The tests below require specific display characteristics. Even so, 342# they are non-portable: some machines don't seem to ever run out of 343# colors. 344 345if {([winfo visual .] == "pseudocolor") && ([winfo depth .] == 8)} { 346 eatColors .t1 347 test frame-3.11 {TkCreateFrame procedure} {nonPortable} { 348 catch {destroy .t} 349 toplevel .t -width 300 -height 200 -bg #475601 350 wm geometry .t +0+0 351 update 352 colorsFree .t 353 } {0} 354 test frame-3.12 {TkCreateFrame procedure} {nonPortable} { 355 catch {destroy .t} 356 toplevel .t -width 300 -height 200 -bg #475601 -colormap new 357 wm geometry .t +0+0 358 update 359 colorsFree .t 360 } {1} 361 test frame-3.13 {TkCreateFrame procedure} {nonPortable} { 362 catch {destroy .t} 363 option add *t.class Toplevel2 364 option add *Toplevel2.colormap new 365 toplevel .t -width 300 -height 200 -bg #475601 366 wm geometry .t +0+0 367 update 368 option clear 369 colorsFree .t 370 } {1} 371 test frame-3.14 {TkCreateFrame procedure} {nonPortable} { 372 catch {destroy .t} 373 option add *t.class Toplevel3 374 option add *Toplevel3.Colormap new 375 toplevel .t -width 300 -height 200 -bg #475601 -colormap new 376 wm geometry .t +0+0 377 update 378 option clear 379 colorsFree .t 380 } {1} 381 test frame-3.15 {TkCreateFrame procedure, -use and -colormap} {unixOnly nonPortable} { 382 catch {destroy .t} 383 catch {destroy .x} 384 toplevel .t -container 1 -width 300 -height 120 385 wm geometry .t +0+0 386 toplevel .x -width 140 -height 300 -use [winfo id .t] -bg green -colormap new 387 tkwait visibility .x 388 set result "[colorsFree .t] [colorsFree .x]" 389 destroy .t 390 set result 391 } {0 1} 392 test frame-3.16 {TkCreateFrame procedure} {nonPortable} { 393 catch {destroy .t} 394 toplevel .t -width 300 -height 200 -bg #475601 -visual default 395 wm geometry .t +0+0 396 update 397 colorsFree .t 398 } {0} 399 test frame-3.17 {TkCreateFrame procedure} {nonPortable} { 400 catch {destroy .t} 401 toplevel .t -width 300 -height 200 -bg #475601 -visual default \ 402 -colormap new 403 wm geometry .t +0+0 404 update 405 colorsFree .t 406 } {1} 407 if {[lsearch -exact [winfo visualsavailable .] {grayscale 8}] >= 0} { 408 test frame-3.18 {TkCreateFrame procedure} {nonPortable} { 409 catch {destroy .t} 410 toplevel .t -visual {grayscale 8} -width 300 -height 200 \ 411 -bg #434343 412 wm geometry .t +0+0 413 update 414 colorsFree .t 131 131 131 415 } {1} 416 test frame-3.19 {TkCreateFrame procedure} {nonPortable} { 417 catch {destroy .t} 418 option add *t.class T4 419 option add *T4.visual {grayscale 8} 420 toplevel .t -width 300 -height 200 -bg #434343 421 wm geometry .t +0+0 422 update 423 option clear 424 list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4] 425 } {1 {grayscale 8}} 426 test frame-3.20 {TkCreateFrame procedure} {nonPortable} { 427 catch {destroy .t} 428 set x ok 429 option add *t.class T5 430 option add *T5.Visual {grayscale 8} 431 toplevel .t -width 300 -height 200 -bg #434343 432 wm geometry .t +0+0 433 update 434 option clear 435 list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4] 436 } {1 {grayscale 8}} 437 test frame-3.21 {TkCreateFrame procedure} {nonPortable} { 438 catch {destroy .t} 439 set x ok 440 toplevel .t -visual {grayscale 8} -width 300 -height 200 \ 441 -bg #434343 442 wm geometry .t +0+0 443 update 444 colorsFree .t 131 131 131 445 } {1} 446 } 447 destroy .t1 448} 449test frame-3.22 {TkCreateFrame procedure, default dimensions} { 450 catch {destroy .t} 451 toplevel .t 452 wm geometry .t +0+0 453 update 454 set result "[winfo reqwidth .t] [winfo reqheight .t]" 455 frame .t.f -bg red 456 pack .t.f 457 update 458 lappend result [winfo reqwidth .t.f] [winfo reqheight .t.f] 459 destroy .t 460 set result 461} {200 200 1 1} 462test frame-3.23 {TkCreateFrame procedure} { 463 catch {destroy .f} 464 list [catch {frame .f -gorp glob} msg] $msg 465} {1 {unknown option "-gorp"}} 466test frame-3.24 {TkCreateFrame procedure} { 467 catch {destroy .t} 468 list [catch { 469 toplevel .t -width 300 -height 200 -colormap new -bogus option 470 wm geometry .t +0+0 471 } msg] $msg 472} {1 {unknown option "-bogus"}} 473 474test frame-4.1 {TkCreateFrame procedure} { 475 catch {destroy .f} 476 catch {frame .f -gorp glob} 477 winfo exists .f 478} 0 479test frame-4.2 {TkCreateFrame procedure} { 480 catch {destroy .f} 481 list [frame .f -width 200 -height 100] [winfo exists .f] 482} {.f 1} 483 484catch {destroy .f} 485frame .f -highlightcolor black 486test frame-5.1 {FrameWidgetCommand procedure} { 487 list [catch .f msg] $msg 488} {1 {wrong # args: should be ".f option ?arg arg ...?"}} 489test frame-5.2 {FrameWidgetCommand procedure, cget option} { 490 list [catch {.f cget} msg] $msg 491} {1 {wrong # args: should be ".f cget option"}} 492test frame-5.3 {FrameWidgetCommand procedure, cget option} { 493 list [catch {.f cget a b} msg] $msg 494} {1 {wrong # args: should be ".f cget option"}} 495test frame-5.4 {FrameWidgetCommand procedure, cget option} { 496 list [catch {.f cget -gorp} msg] $msg 497} {1 {unknown option "-gorp"}} 498test frame-5.5 {FrameWidgetCommand procedure, cget option} { 499 .f cget -highlightcolor 500} {black} 501test frame-5.6 {FrameWidgetCommand procedure, cget option} { 502 list [catch {.f cget -screen} msg] $msg 503} {1 {unknown option "-screen"}} 504test frame-5.7 {FrameWidgetCommand procedure, cget option} { 505 catch {destroy .t} 506 toplevel .t 507 catch {.t cget -screen} 508} {0} 509catch {destroy .t} 510test frame-5.8 {FrameWidgetCommand procedure, configure option} { 511 llength [.f configure] 512} {18} 513test frame-5.9 {FrameWidgetCommand procedure, configure option} { 514 list [catch {.f configure -gorp} msg] $msg 515} {1 {unknown option "-gorp"}} 516test frame-5.10 {FrameWidgetCommand procedure, configure option} { 517 list [catch {.f configure -gorp bogus} msg] $msg 518} {1 {unknown option "-gorp"}} 519test frame-5.11 {FrameWidgetCommand procedure, configure option} { 520 list [catch {.f configure -width 200 -height} msg] $msg 521} {1 {value for "-height" missing}} 522test frame-5.12 {FrameWidgetCommand procedure} { 523 list [catch {.f swizzle} msg] $msg 524} {1 {bad option "swizzle": must be cget or configure}} 525test frame-5.13 {FrameWidgetCommand procedure, configure option} { 526 llength [. configure] 527} {21} 528 529test frame-6.1 {ConfigureFrame procedure} { 530 catch {destroy .f} 531 frame .f -width 150 532 list [winfo reqwidth .f] [winfo reqheight .f] 533} {150 1} 534test frame-6.2 {ConfigureFrame procedure} { 535 catch {destroy .f} 536 frame .f -height 97 537 list [winfo reqwidth .f] [winfo reqheight .f] 538} {1 97} 539test frame-6.3 {ConfigureFrame procedure} { 540 catch {destroy .f} 541 frame .f 542 set result {} 543 lappend result [winfo reqwidth .f] [winfo reqheight .f] 544 .f configure -width 100 -height 180 545 lappend result [winfo reqwidth .f] [winfo reqheight .f] 546 .f configure -width 0 -height 0 547 lappend result [winfo reqwidth .f] [winfo reqheight .f] 548} {1 1 100 180 100 180} 549 550test frame-7.1 {FrameEventProc procedure} { 551 frame .frame2 552 set result [info commands .frame2] 553 destroy .frame2 554 lappend result [info commands .frame2] 555} {.frame2 {}} 556test frame-7.2 {FrameEventProc procedure} { 557 deleteWindows 558 frame .f1 -bg #543210 559 rename .f1 .f2 560 set x {} 561 lappend x [winfo children .] 562 lappend x [.f2 cget -bg] 563 destroy .f1 564 lappend x [info command .f*] [winfo children .] 565} {.f1 #543210 {} {}} 566 567test frame-8.1 {FrameCmdDeletedProc procedure} { 568 deleteWindows 569 frame .f1 570 rename .f1 {} 571 list [info command .f*] [winfo children .] 572} {{} {}} 573test frame-8.2 {FrameCmdDeletedProc procedure} { 574 deleteWindows 575 toplevel .f1 -menu .m 576 wm geometry .f1 +0+0 577 update 578 rename .f1 {} 579 update 580 list [info command .f*] [winfo children .] 581} {{} {}} 582# 583# This one fails with the dash-patch!!!! Still don't know why :-( 584# 585#test frame-8.3 {FrameCmdDeletedProc procedure} { 586# eval destroy [winfo children .] 587# toplevel .f1 -menu .m 588# wm geometry .f1 +0+0 589# menu .m 590# update 591# rename .f1 {} 592# update 593# set result [list [info command .f*] [winfo children .]] 594# eval destroy [winfo children .] 595# set result 596#} {{} .m} 597 598test frame-9.1 {MapFrame procedure} { 599 catch {destroy .t} 600 toplevel .t -width 100 -height 400 601 wm geometry .t +0+0 602 set result [winfo ismapped .t] 603 update idletasks 604 lappend result [winfo ismapped .t] 605} {0 1} 606test frame-9.2 {MapFrame procedure} { 607 catch {destroy .t} 608 toplevel .t -width 100 -height 400 609 wm geometry .t +0+0 610 destroy .t 611 update 612 winfo exists .t 613} {0} 614test frame-9.3 {MapFrame procedure, window deleted while mapping} { 615 toplevel .t2 -width 200 -height 200 616 wm geometry .t2 +0+0 617 tkwait visibility .t2 618 catch {destroy .t} 619 toplevel .t -width 100 -height 400 620 wm geometry .t +0+0 621 frame .t2.f -width 50 -height 50 622 bind .t2.f <Configure> {destroy .t} 623 pack .t2.f -side top 624 update idletasks 625 winfo exists .t 626} {0} 627 628set l [interp hidden] 629deleteWindows 630 631test frame-10.1 {frame widget vs hidden commands} { 632 catch {destroy .t} 633 frame .t 634 interp hide {} .t 635 destroy .t 636 list [winfo children .] [interp hidden] 637} [list {} $l] 638 639test frame-11.1 {TkInstallFrameMenu} { 640 catch {destroy .t} 641 menu .m1 642 .m1 add cascade -menu .m1.system 643 menu .m1.system -tearoff 0 644 .m1.system add command -label foo 645 list [toplevel .t -menu .m1] [destroy .m1] [destroy .t] 646} {.t {} {}} 647test frame-11.2 {TkInstallFrameMenu - frame renamed} { 648 catch {destroy .t} 649 catch {rename foo {}} 650 menu .m1 651 .m1 add cascade -menu .m1.system 652 menu .m1.system -tearoff 0 653 .m1.system add command -label foo 654 toplevel .t 655 list [rename .t foo] [destroy .t] [destroy foo] [destroy .m1] 656} {{} {} {} {}} 657 658test frame-12.1 {FrameWorldChanged procedure} { 659 # Test -bd -padx and -pady 660 destroy .f 661 frame .f -borderwidth 2 -padx 3 -pady 4 662 place .f -x 0 -y 0 -width 40 -height 40 663 pack [frame .f.f] -fill both -expand 1 664 update 665 set result [list [winfo x .f.f] [winfo y .f.f] \ 666 [winfo width .f.f] [winfo height .f.f]] 667 destroy .f 668 set result 669} {5 6 30 28} 670test frame-12.2 {FrameWorldChanged procedure} { 671 # Test all -labelanchor positions 672 destroy .f 673 set font {helvetica 12} 674 labelframe .f -highlightthickness 1 -bd 3 -padx 1 -pady 2 -font $font \ 675 -text "Mupp" 676 set fh [expr {[font metrics $font -linespace] + 2 - 3}] 677 set fw [expr {[font measure $font "Mupp"] + 2 - 3}] 678 if {$fw < 0} {set fw 0} 679 if {$fh < 0} {set fh 0} 680 place .f -x 0 -y 0 -width 100 -height 100 681 pack [frame .f.f] -fill both -expand 1 682 683 set result {} 684 foreach lp {nw n ne en e es se s sw ws w wn} { 685 .f configure -labelanchor $lp 686 update 687 set expx 5 688 set expy 6 689 set expw 90 690 set exph 88 691 switch -glob $lp { 692 n* {incr expy $fh ; incr exph -$fh} 693 s* {incr exph -$fh} 694 w* {incr expx $fw ; incr expw -$fw} 695 e* {incr expw -$fw} 696 } 697 lappend result [expr {\ 698 [winfo x .f.f] == $expx && [winfo y .f.f] == $expy &&\ 699 [winfo width .f.f] == $expw && [winfo height .f.f] == $exph}] 700 } 701 destroy .f 702 set result 703} {1 1 1 1 1 1 1 1 1 1 1 1} 704test frame-12.3 {FrameWorldChanged procedure} { 705 # Check reaction on font change 706 destroy .f 707 font create myfont -family courier -size 10 708 labelframe .f -font myfont -text Mupp 709 place .f -x 0 -y 0 -width 40 -height 40 710 pack [frame .f.f] -fill both -expand 1 711 update 712 set h1 [font metrics myfont -linespace] 713 set y1 [winfo y .f.f] 714 font configure myfont -size 20 715 update 716 set h2 [font metrics myfont -linespace] 717 set y2 [winfo y .f.f] 718 destroy .f 719 font delete myfont 720 expr {($h2 - $h1) - ($y2 - $y1)} 721} {0} 722 723test frame-13.1 {labelframe configuration options} { 724 labelframe .f -class NewFrame 725 list [.f configure -class] [catch {.f configure -class Different} msg] $msg 726} {{-class class Class Labelframe NewFrame} 1 {can't modify -class option after widget is created}} 727catch {destroy .f} 728test frame-13.2 {labelframe configuration options} { 729 list [catch {labelframe .f -colormap new} msg] $msg 730} {0 .f} 731catch {destroy .f} 732test frame-13.3 {labelframe configuration options} { 733 list [catch {labelframe .f -visual default} msg] $msg 734} {0 .f} 735catch {destroy .f} 736test frame-13.4 {labelframe configuration options} { 737 list [catch {labelframe .f -screen bogus} msg] $msg 738} {1 {unknown option "-screen"}} 739test frame-13.5 {labelframe configuration options} { 740 set result [list [catch {labelframe .f -container true} msg] $msg \ 741 [.f configure -container]] 742 destroy .f 743 set result 744} {0 .f {-container container Container 0 1}} 745test frame-13.6 {labelframe configuration options} { 746 list [catch {labelframe .f -container bogus} msg] $msg 747} {1 {expected boolean value but got "bogus"}} 748test frame-13.7 {labelframe configuration options} { 749 labelframe .f 750 set result [list [catch {.f configure -container 1} msg] $msg] 751 destroy .f 752 set result 753} {1 {can't modify -container option after widget is created}} 754labelframe .f 755set i 8 756foreach test { 757 {-background #ff0000 #ff0000 non-existent 758 {unknown color name "non-existent"}} 759 {-bd 4 4 badValue {bad screen distance "badValue"}} 760 {-bg #00ff00 #00ff00 non-existent 761 {unknown color name "non-existent"}} 762 {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} 763 {-cursor arrow arrow badValue {bad cursor spec "badValue"}} 764 {-fg #0000ff #0000ff non-existent 765 {unknown color name "non-existent"}} 766 {-font {courier 8} {courier 8} {} {}} 767 {-foreground #ff0000 #ff0000 non-existent 768 {unknown color name "non-existent"}} 769 {-height 100 100 not_a_number {bad screen distance "not_a_number"}} 770 {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} 771 {-highlightcolor #123456 #123456 non-existent 772 {unknown color name "non-existent"}} 773 {-highlightthickness 6 6 badValue {bad screen distance "badValue"}} 774 {-labelanchor se se badValue {bad labelanchor "badValue": must be e, en, es, n, ne, nw, s, se, sw, w, wn, or ws}} 775 {-padx 3 3 badValue {bad screen distance "badValue"}} 776 {-pady 4 4 badValue {bad screen distance "badValue"}} 777 {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}} 778 {-takefocus "any string" "any string" {} {}} 779 {-text "any string" "any string" {} {}} 780 {-width 32 32 badValue {bad screen distance "badValue"}} 781} { 782 set name [lindex $test 0] 783 test frame-13.$i {labelframe configuration options} { 784 .f configure $name [lindex $test 1] 785 lindex [.f configure $name] 4 786 } [lindex $test 2] 787 incr i 788 if {[lindex $test 3] != ""} { 789 test frame-13.$i {labelframe configuration options} { 790 list [catch {.f configure $name [lindex $test 3]} msg] $msg 791 } [list 1 [lindex $test 4]] 792 } 793 .f configure $name [lindex [.f configure $name] 3] 794 incr i 795} 796destroy .f 797 798test frame-14.1 {labelframe labelwidget option} { 799 # Test that label is moved in stacking order 800 destroy .f .l 801 label .l -text Mupp 802 labelframe .f -labelwidget .l 803 pack .f 804 frame .f.f -width 50 -height 50 805 pack .f.f 806 update 807 set res [list [winfo children .] [winfo width .f] \ 808 [expr {[winfo height .f] - [winfo height .l]}]] 809 destroy .f .l 810 set res 811} {{.f .l} 54 52} 812test frame-14.2 {labelframe labelwidget option} { 813 # Test the labelframe's reaction if the label is destroyed 814 destroy .f .l 815 label .l -text Aratherlonglabel 816 labelframe .f -labelwidget .l 817 pack .f 818 label .f.l -text Mupp 819 pack .f.l 820 update 821 set res [list [.f cget -labelwidget]] 822 lappend res [expr {[winfo width .f] - [winfo width .l]}] 823 destroy .l 824 lappend res [.f cget -labelwidget] 825 update 826 lappend res [expr {[winfo width .f] - [winfo width .f.l]}] 827 destroy .f 828 set res 829} {.l 12 {} 4} 830test frame-14.3 {labelframe labelwidget option} { 831 # Test the labelframe's reaction if the label is stolen 832 destroy .f .l 833 label .l -text Aratherlonglabel 834 labelframe .f -labelwidget .l 835 pack .f 836 label .f.l -text Mupp 837 pack .f.l 838 update 839 set res [list [.f cget -labelwidget]] 840 lappend res [expr {[winfo width .f] - [winfo width .l]}] 841 pack .l 842 lappend res [.f cget -labelwidget] 843 update 844 lappend res [expr {[winfo width .f] - [winfo width .f.l]}] 845 destroy .f .l 846 set res 847} {.l 12 {} 4} 848test frame-14.4 {labelframe labelwidget option} { 849 # Test the label's reaction if the labelframe is destroyed 850 destroy .f .l 851 label .l -text Mupp 852 labelframe .f -labelwidget .l 853 pack .f 854 update 855 set res [list [winfo manager .l]] 856 destroy .f 857 lappend res [winfo manager .l] 858 destroy .l 859 set res 860} {labelframe {}} 861test frame-14.5 {labelframe labelwidget option} { 862 # Test that the labelframe reacts on changes in label 863 destroy .f .l 864 label .l -text Aratherlonglabel 865 labelframe .f -labelwidget .l 866 pack .f 867 label .f.l -text Mupp 868 pack .f.l 869 update 870 set first [winfo width .f] 871 set res [expr {[winfo width .f] - [winfo width .l]}] 872 .l configure -text Shorter 873 update 874 lappend res [expr {[winfo width .f] - [winfo width .l]}] 875 lappend res [expr {[winfo width .f] < $first}] 876 .l configure -text Alotlongerthananytimebefore 877 update 878 lappend res [expr {[winfo width .f] - [winfo width .l]}] 879 lappend res [expr {[winfo width .f] > $first}] 880 destroy .f .l 881 set res 882} {12 12 1 12 1} 883test frame-14.6 {labelframe labelwidget option} { 884 # Destroying a labelframe with a child label caused a crash 885 # when not handling mapping of the label correctly. 886 # This test does not test anything directly, it's just ment 887 # to catch if the same mistake is made again. 888 destroy .f 889 labelframe .f 890 pack .f 891 label .f.l -text Mupp 892 .f configure -labelwidget .f.l 893 update 894 destroy .f 895} {} 896 897catch {destroy .f} 898rename eatColors {} 899rename colorsFree {} 900 901# cleanup 902::tcltest::cleanupTests 903return 904