1# This file is a Tcl script to test drawing of menus in Tk. It is 2# organized in the standard fashion for Tcl tests. 3# 4# Copyright (c) 1996-1997 Sun Microsystems, Inc. 5# Copyright (c) 1998-1999 by Scriptics Corporation. 6# All rights reserved. 7# 8# RCS: @(#) $Id: menuDraw.test,v 1.5 2002/07/13 20:28:35 dgp Exp $ 9 10package require tcltest 2.1 11namespace import -force tcltest::configure 12namespace import -force tcltest::testsDirectory 13configure -testdir [file join [pwd] [file dirname [info script]]] 14configure -loadfile [file join [testsDirectory] constraints.tcl] 15tcltest::loadTestedCommands 16 17test menuDraw-1.1 {TkMenuInitializeDrawingFields} { 18 catch {destroy .m1} 19 list [menu .m1] [destroy .m1] 20} {.m1 {}} 21 22test menuDraw-2.1 {TkIntializeMenuEntryDrawingFields} { 23 catch {destroy .m1} 24 menu .m1 25 list [.m1 add command] [destroy .m1] 26} {{} {}} 27 28test menuDraw-3.1 {TkMenuFreeDrawOptions} { 29 catch {destroy .m1} 30 menu .m1 31 list [destroy .m1] 32} {{}} 33 34test menuDraw-4.1 {TkMenuEntryFreeDrawOptions} { 35 catch {destroy .m1} 36 menu .m1 37 .m1 add command -label "This is a test" 38 list [destroy .m1] 39} {{}} 40test menuDraw-4.2 {TkMenuEntryFreeDrawOptions} { 41 catch {destroy .m1} 42 menu .m1 43 .m1 add checkbutton -label "This is a test." -font "Courier 12" -activeforeground red -background green -selectcolor purple 44 list [destroy .m1] 45} {{}} 46 47test menuDraw-5.1 {TkMenuConfigureDrawOptions - new menu} { 48 catch {destroy .m1} 49 list [menu .m1] [destroy .m1] 50} {.m1 {}} 51test menuDraw-5.2 {TkMenuConfigureDrawOptions - old menu} { 52 catch {destroy .m1} 53 menu .m1 54 list [.m1 configure -fg red] [destroy .m1] 55} {{} {}} 56test menuDraw-5.3 {TkMenuConfigureDrawOptions - no disabledFg} { 57 catch {destroy .m1} 58 list [menu .m1 -disabledforeground ""] [destroy .m1] 59} {.m1 {}} 60 61test menuDraw-6.1 {TkMenuConfigureEntryDrawOptions - no tkfont specified} { 62 catch {destroy .m1} 63 menu .m1 64 list [.m1 add command -label "foo"] [destroy .m1] 65} {{} {}} 66test menuDraw-6.2 {TkMenuConfigureEntryDrawOptions - tkfont specified} { 67 catch {destroy .m1} 68 menu .m1 69 list [.m1 add command -label "foo" -font "Courier 12"] [destroy .m1] 70} {{} {}} 71test menuDraw-6.3 {TkMenuConfigureEntryDrawOptions - active state - wrong entry} { 72 catch {destroy .m1} 73 menu .m1 74 .m1 add command -label "foo" 75 list [.m1 entryconfigure 1 -state active] [destroy .m1] 76} {{} {}} 77test menuDraw-6.4 {TkMenuConfigureEntryDrawOptions - active state - correct entry} { 78 catch {destroy .m1} 79 menu .m1 80 .m1 add command -label "foo" 81 .m1 activate 1 82 list [.m1 entryconfigure 1 -state active] [destroy .m1] 83} {{} {}} 84test menuDraw-6.5 {TkMenuConfigureEntryDrawOptions - deactivate entry} { 85 catch {destroy .m1} 86 menu .m1 87 .m1 add command -label "foo" 88 .m1 activate 1 89 list [.m1 entryconfigure 1 -state normal] [destroy .m1] 90} {{} {}} 91test menuDraw-6.6 {TkMenuConfigureEntryDrawOptions - bad state} { 92 catch {destroy .m1} 93 menu .m1 94 .m1 add command -label "foo" 95 list [catch {.m1 entryconfigure 1 -state foo} msg] $msg [destroy .m1] 96} {1 {bad state "foo": must be active, normal, or disabled} {}} 97test menuDraw-6.7 {TkMenuConfigureEntryDrawOptions - tkfont specified} { 98 catch {destroy .m1} 99 menu .m1 100 list [.m1 add command -label "foo" -font "Courier 12"] [destroy .m1] 101} {{} {}} 102test menuDraw-6.8 {TkMenuConfigureEntryDrawOptions - border specified} { 103 catch {destroy .m1} 104 menu .m1 105 list [.m1 add command -label "foo" -background "red"] [destroy .m1] 106} {{} {}} 107test menuDraw-6.9 {TkMenuConfigureEntryDrawOptions - foreground specified} { 108 catch {destroy .m1} 109 menu .m1 110 list [.m1 add command -label "foo" -foreground "red"] [destroy .m1] 111} {{} {}} 112test menuDraw-6.10 {TkMenuConfigureEntryDrawOptions - activeBorder specified} { 113 catch {destroy .m1} 114 menu .m1 115 list [.m1 add command -label "foo" -activebackground "red"] [destroy .m1] 116} {{} {}} 117test menuDraw-6.11 {TkMenuConfigureEntryDrawOptions - activeforeground specified} { 118 catch {destroy .m1} 119 menu .m1 120 list [.m1 add command -label "foo" -activeforeground "red"] [destroy .m1] 121} {{} {}} 122test menuDraw-6.12 {TkMenuConfigureEntryDrawOptions - selectcolor specified} { 123 catch {destroy .m1} 124 menu .m1 125 list [.m1 add radiobutton -label "foo" -selectcolor "red"] [destroy .m1] 126} {{} {}} 127test menuDraw-6.13 {TkMenuConfigureEntryDrawOptions - textGC disposal} { 128 catch {destroy .m1} 129 menu .m1 130 .m1 add command -label "foo" -font "Helvetica 12" 131 list [.m1 entryconfigure 1 -font "Courier 12"] [destroy .m1] 132} {{} {}} 133test menuDraw-6.14 {TkMenuConfigureEntryDrawOptions - activeGC disposal} { 134 catch {destroy .m1} 135 menu .m1 136 .m1 add command -label "foo" -activeforeground "red" 137 list [.m1 entryconfigure 1 -activeforeground "green"] [destroy .m1] 138} {{} {}} 139test menuDraw-6.15 {TkMenuConfigureEntryDrawOptions - disabledGC disposal} { 140 catch {destroy .m1} 141 menu .m1 -disabledforeground "red" 142 .m1 add command -label "foo" 143 list [.m1 configure -disabledforeground "green"] [destroy .m1] 144} {{} {}} 145test menuDraw-6.16 {TkMenuConfigureEntryDrawOptions - indicatorGC disposal} { 146 catch {destroy .m1} 147 menu .m1 148 .m1 add radiobutton -label "foo" -selectcolor "red" 149 list [.m1 entryconfigure 1 -selectcolor "green"] [destroy .m1] 150} {{} {}} 151 152test menuDraw-7.1 {TkEventuallyRecomputeMenu} { 153 catch {destroy .m1} 154 menu .m1 155 .m1 add command -label "This is a long label" 156 set tearoff [tk::TearOffMenu .m1] 157 update idletasks 158 list [.m1 entryconfigure 1 -label "foo"] [destroy .m1] 159} {{} {}} 160test menuDraw-7.2 {TkEventuallyRecomputeMenu - update pending} { 161 catch {destroy .m1} 162 menu .m1 163 .m1 add command -label "This is a long label" 164 set tearoff [tk::TearOffMenu .m1] 165 list [.m1 entryconfigure 1 -label "foo"] [destroy .m1] 166} {{} {}} 167 168 169test menuDraw-8.1 {TkRecomputeMenu} {pcOnly userInteraction} { 170 catch {destroy .m1} 171 menu .m1 172 .m1 configure -postcommand [.m1 add command -label foo] 173 .m1 add command -label "Hit ESCAPE to make this menu go away." 174 list [.m1 post 0 0] [destroy .m1] 175} {{} {}} 176 177 178test menuDraw-9.1 {TkEventuallyRedrawMenu - entry test} { 179 catch {destroy .m1} 180 catch {unset foo} 181 menu .m1 182 set foo 0 183 .m1 add radiobutton -variable foo -label test 184 tk::TearOffMenu .m1 185 update idletasks 186 list [set foo test] [destroy .m1] [unset foo] 187} {test {} {}} 188test menuDraw-9.2 {TkEventuallyRedrawMenu - whole menu} { 189 catch {destroy .m1} 190 menu .m1 191 list [catch {tk::TearOffMenu .m1}] [destroy .m1] 192} {0 {}} 193 194# Don't know how to test when window has been deleted and ComputeMenuGeometry 195# gets called. 196test menuDraw-10.1 {ComputeMenuGeometry - menubar} { 197 catch {destroy .m1} 198 menu .m1 199 .m1 add command -label test 200 . configure -menu .m1 201 list [update idletasks] [. configure -menu ""] [destroy .m1] 202} {{} {} {}} 203test menuDraw-10.2 {ComputeMenuGeometry - non-menubar} { 204 catch {destroy .m1} 205 menu .m1 206 .m1 add command -label test 207 list [update idletasks] [destroy .m1] 208} {{} {}} 209test menuDraw-10.3 {ComputeMenuGeometry - Resize necessary} { 210 catch {destroy .m1} 211 menu .m1 212 .m1 add command -label test 213 list [update idletasks] [destroy .m1] 214} {{} {}} 215test menuDraw-10.4 {ComputeMenuGeometry - resize not necessary} { 216 catch {destroy .m1} 217 menu .m1 218 .m1 add command -label test 219 update idletasks 220 .m1 entryconfigure 1 -label test 221 list [update idletasks] [destroy .m1] 222} {{} {}} 223 224test menuDraw-11.1 {TkMenuSelectImageProc - entry selected; redraw not pending} testImageType { 225 catch {destroy .m1} 226 catch {eval image delete [image names]} 227 image create test image1 228 image create test image2 229 menu .m1 230 .m1 add checkbutton -image image1 -selectimage image2 231 .m1 invoke 1 232 set tearoff [tk::TearOffMenu .m1 40 40] 233 update idletasks 234 list [image delete image2] [destroy .m1] [eval image delete [image names]] 235} {{} {} {}} 236test menuDraw-11.2 {TkMenuSelectImageProc - entry selected; redraw pending} testImageType { 237 catch {destroy .m1} 238 catch {eval image delete [image names]} 239 image create test image1 240 image create test image2 241 menu .m1 242 .m1 add checkbutton -image image1 -selectimage image2 243 .m1 invoke 1 244 set tearoff [tk::TearOffMenu .m1 40 40] 245 list [image delete image2] [destroy .m1] [eval image delete [image names]] 246} {{} {} {}} 247test menuDraw-11.3 {TkMenuSelectImageProc - entry not selected} testImageType { 248 catch {destroy .m1} 249 catch {eval image delete [image names]} 250 image create test image1 251 image create test image2 252 menu .m1 253 .m1 add checkbutton -image image1 -selectimage image2 254 set tearoff [tk::TearOffMenu .m1 40 40] 255 update idletasks 256 list [image delete image2] [destroy .m1] [eval image delete [image names]] 257} {{} {} {}} 258 259#Don't know how to test missing tkwin in DisplayMenu 260test menuDraw-12.1 {DisplayMenu - menubar background} {unixOnly} { 261 catch {destroy .m1} 262 menu .m1 263 .m1 add cascade -label foo -menu .m2 264 . configure -menu .m1 265 list [update] [. configure -menu ""] [destroy .m1] 266} {{} {} {}} 267test menuDraw-12.2 {Display menu - no entries} { 268 catch {destroy .m1} 269 menu .m1 270 set tearoff [tk::TearOffMenu .m1 40 40] 271 list [update] [destroy .m1] 272} {{} {}} 273test menuDraw-12.3 {DisplayMenu - one entry} { 274 catch {destroy .m1} 275 menu .m1 276 .m1 add command -label foo 277 set tearoff [tk::TearOffMenu .m1 40 40] 278 list [update] [destroy .m1] 279} {{} {}} 280test menuDraw-12.4 {DisplayMenu - two entries} { 281 catch {destroy .m1} 282 menu .m1 283 .m1 add command -label "one" 284 .m1 add command -label "two" 285 set tearoff [tk::TearOffMenu .m1 40 40] 286 list [update] [destroy .m1] 287} {{} {}} 288test menuDraw.12.5 {DisplayMenu - two columns - first bigger} { 289 catch {destroy .m1} 290 menu .m1 291 .m1 add command -label "one" 292 .m1 add command -label "two" 293 .m1 add command -label "three" -columnbreak 1 294 set tearoff [tk::TearOffMenu .m1 40 40] 295 list [update] [destroy .m1] 296} {{} {}} 297test menuDraw-12.5 {DisplayMenu - two column - second bigger} { 298 catch {destroy .m1} 299 menu .m1 300 .m1 add command -label "one" 301 .m1 add command -label "two" -columnbreak 1 302 .m1 add command -label "three" 303 set tearoff [tk::TearOffMenu .m1 40 40] 304 list [update] [destroy .m1] 305} {{} {}} 306test menuDraw.12.7 {DisplayMenu - three columns} { 307 catch {destroy .m1} 308 menu .m1 309 .m1 add command -label "one" 310 .m1 add command -label "two" -columnbreak 1 311 .m1 add command -label "three" 312 .m1 add command -label "four" 313 .m1 add command -label "five" 314 .m1 add command -label "six" 315 set tearoff [tk::TearOffMenu .m1 40 40] 316 list [update] [destroy .m1] 317} {{} {}} 318test menuDraw-12.6 {Display menu - testing for extra space and menubars} {unixOnly} { 319 catch {destroy .m1} 320 menu .m1 321 .m1 add cascade -label foo 322 . configure -menu .m1 323 list [update] [. configure -menu ""] [destroy .m1] 324} {{} {} {}} 325test menuDraw-12.7 {Display menu - extra space at end of menu} { 326 catch {destroy .m1} 327 menu .m1 328 .m1 add cascade -label foo 329 set tearoff [tk::TearOffMenu .m1 40 40] 330 wm geometry $tearoff 200x100 331 list [update] [destroy .m1] 332} {{} {}} 333 334test menuDraw-13.1 {TkMenuEventProc - Expose} { 335 catch {destroy .m1} 336 catch {destroy .m2} 337 menu .m1 338 .m1 add command -label "one" 339 menu .m2 340 .m2 add command -label "two" 341 set tearoff1 [tk::TearOffMenu .m1 40 40] 342 set tearoff2 [tk::TearOffMenu .m2 40 40] 343 list [raise $tearoff2] [update] [destroy .m1] [destroy .m2] 344} {{} {} {} {}} 345test menuDraw-13.2 {TkMenuEventProc - ConfigureNotify} { 346 catch {destroy .m1} 347 menu .m1 348 .m1 add command -label "foo" 349 set tearoff [tk::TearOffMenu .m1 40 40] 350 list [wm geometry $tearoff 200x100] [update] [destroy .m1] 351} {{} {} {}} 352test menuDraw-13.3 {TkMenuEventProc - ActivateNotify} {macOnly} { 353 catch {destroy .t2} 354 toplevel .t2 -menu .t2.m1 355 menu .t2.m1 356 .t2.m1 add command -label foo 357 tk::TearOffMenu .t2.m1 40 40 358 list [catch {update} msg] $msg [destroy .t2] 359} {0 {} {}} 360# Testing deletes is hard, and I am going to do my best. Don't know how 361# to test the case where we have already cleared the tkwin field in the 362# menuPtr. 363test menuDraw-13.4 {TkMenuEventProc - simple delete} { 364 catch {destroy .m1} 365 menu .m1 366 list [destroy .m1] 367} {{}} 368test menuDraw-13.5 {TkMenuEventProc - nothing pending} { 369 catch {destroy .m1} 370 menu .m1 371 .m1 add command -label foo 372 update idletasks 373 list [destroy .m1] 374} {{}} 375 376test menuDraw-14.1 {TkMenuImageProc} testImageType { 377 catch {destroy .m1} 378 catch {image delete image1} 379 menu .m1 380 image create test image1 381 .m1 add command -image image1 382 update idletasks 383 list [image delete image1] [destroy .m1] 384} {{} {}} 385test menuDraw-14.2 {TkMenuImageProc} testImageType { 386 catch {destroy .m1} 387 catch {image delete image1} 388 menu .m1 389 image create test image1 390 .m1 add command -image image1 391 list [image delete image1] [destroy .m1] 392} {{} {}} 393 394test menuDraw-15.1 {TkPostTearoffMenu - Basic posting} { 395 catch {destroy .m1} 396 menu .m1 397 .m1 add command -label "foo" 398 list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] 399} {0 {}} 400test menuDraw-15.2 {TkPostTearoffMenu - Deactivation} { 401 catch {destroy .m1} 402 menu .m1 403 .m1 add command -label "foo" -state active 404 set tearoff [tk::TearOffMenu .m1 40 40] 405 list [$tearoff index active] [destroy .m1] 406} {none {}} 407test menuDraw-15.3 {TkPostTearoffMenu - post command} { 408 catch {destroy .m1} 409 catch {unset foo} 410 menu .m1 -postcommand "set foo .m1" 411 .m1 add command -label "foo" 412 list [catch {tk::TearOffMenu .m1 40 40}] [set foo] [unset foo] [destroy .m1] 413} {0 .m1 {} {}} 414test menuDraw-15.4 {TkPostTearoffMenu - post command deleting the menu} { 415 catch {destroy .m1} 416 menu .m1 -postcommand "destroy .m1" 417 .m1 add command -label "foo" 418 list [catch {tk::TearOffMenu .m1 40 40} msg] $msg [winfo exists .m1] 419} {0 {} 0} 420test menuDraw-15.5 {TkPostTearoffMenu - tearoff at edge of screen} { 421 catch {destroy .m1} 422 menu .m1 423 .m1 add command -label "foo" 424 set height [winfo screenheight .m1] 425 list [catch {tk::TearOffMenu .m1 40 $height}] [destroy .m1] 426} {0 {}} 427test menuDraw-15.6 {TkPostTearoffMenu - tearoff off right} { 428 catch {destroy .m1} 429 menu .m1 430 .m1 add command -label "foo" 431 set width [winfo screenwidth .m1] 432 list [catch {tk::TearOffMenu .m1 $width 40}] [destroy .m1] 433} {0 {}} 434 435 436test menuDraw-16.1 {TkPostSubmenu} {unixOnly} { 437 catch {destroy .m1} 438 catch {destroy .m2} 439 menu .m1 440 .m1 add cascade -label test -menu .m2 441 menu .m2 442 .m2 add command -label "Hit ESCAPE to make this menu go away." 443 set tearoff [tk::TearOffMenu .m1 40 40] 444 $tearoff postcascade 0 445 list [$tearoff postcascade 0] [destroy .m1] [destroy .m2] 446} {{} {} {}} 447test menuDraw-16.2 {TkPostSubMenu} {unixOnly} { 448 catch {destroy .m1} 449 catch {destroy .m2} 450 catch {destroy .m3} 451 menu .m1 452 .m1 add cascade -label "two" -menu .m2 453 .m1 add cascade -label "three" -menu .m3 454 menu .m2 455 .m2 add command -label "two" 456 menu .m3 457 .m3 add command -label "three" 458 set tearoff [tk::TearOffMenu .m1 40 40] 459 $tearoff postcascade 0 460 list [$tearoff postcascade 1] [destroy .m1] [destroy .m2] [destroy .m3] 461} {{} {} {} {}} 462test menuDraw-16.3 {TkPostSubMenu} { 463 catch {destroy .m1} 464 menu .m1 465 .m1 add cascade -label test -menu .m2 466 list [.m1 postcascade 1] [destroy .m1] 467} {{} {}} 468test menuDraw-16.4 {TkPostSubMenu} { 469 catch {destroy .m1} 470 menu .m1 471 .m1 add cascade -label test 472 set tearoff [tk::TearOffMenu .m1 40 40] 473 list [$tearoff postcascade 0] [destroy .m1] 474} {{} {}} 475test menuDraw-16.5 {TkPostSubMenu} {unixOnly} { 476 catch {destroy .m1} 477 catch {destroy .m2} 478 menu .m1 479 .m1 add cascade -label test -menu .m2 480 menu .m2 -postcommand "glorp" 481 set tearoff [tk::TearOffMenu .m1 40 40] 482 list [catch {$tearoff postcascade test} msg] $msg [destroy .m1] [destroy .m2] 483} {1 {invalid command name "glorp"} {} {}} 484test menuDraw-16.6 {TkPostSubMenu} {pcOnly userInteraction} { 485 catch {destroy .m1} 486 catch {destroy .m2} 487 menu .m1 488 .m1 add cascade -label test -menu .m2 489 menu .m2 490 .m2 add command -label "Hit ESCAPE to get rid of this menu" 491 set tearoff [tk::TearOffMenu .m1 40 40] 492 list [$tearoff postcascade 0] [destroy .m1] [destroy .m2] 493} {{} {} {}} 494 495test menuDraw-17.1 {AdjustMenuCoords - menubar} {unixOnly} { 496 catch {destroy .m1} 497 catch {destroy .m2} 498 menu .m1 -tearoff 0 499 .m1 add cascade -label test -menu .m2 500 menu .m2 -tearoff 0 501 .m2 add command -label foo 502 . configure -menu .m1 503 foreach w [winfo children .] { 504 if {[$w cget -type] == "menubar"} { 505 break 506 } 507 } 508 list [$w postcascade 0] [. configure -menu ""] [destroy .m1] [destroy .m2] 509} {{} {} {} {}} 510test menuDraw-17.2 {AdjustMenuCoords - menu} {pcOnly userInteraction} { 511 catch {destroy .m1} 512 catch {destroy .m2} 513 menu .m1 514 .m1 add cascade -label test -menu .m2 515 menu .m2 516 .m2 add command -label "Hit ESCAPE to make this menu go away" 517 set tearoff [tk::TearOffMenu .m1 40 40] 518 list [$tearoff postcascade 0] [destroy .m1] [destroy .m2] 519} {{} {} {}} 520 521# cleanup 522deleteWindows 523::tcltest::cleanupTests 524return 525 526 527 528 529 530 531 532 533 534 535 536 537 538