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