1# This file is a Tcl script to test menus in Tk. It is 2# organized in the standard fashion for Tcl tests. 3# 4# Copyright (c) 1995-1997 Sun Microsystems, Inc. 5# Copyright (c) 1998-1999 by Scriptics Corporation. 6# All rights reserved. 7# 8# RCS: @(#) $Id: menu.test,v 1.13.2.2 2006/11/24 18:11:54 hobbs 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 menu-1.1 {Tk_MenuCmd procedure} { 18 list [catch menu msg] $msg 19} {1 {wrong # args: should be "menu pathName ?options?"}} 20test menu-1.2 {Tk_MenuCmd procedure} { 21 list [catch "menu bogus" msg] $msg 22} {1 {bad window path name "bogus"}} 23test menu-1.3 {Tk_MenuCmd procedure} { 24 list [catch "menu .m1 foo" msg] $msg 25} {1 {unknown option "foo"}} 26test menu-1.4 {Tk_MenuCmd procedure} { 27 catch {destroy .m1} 28 list [catch {menu .m1} msg] $msg [destroy .m1] 29} {0 .m1 {}} 30test menu-1.5 {Tk_MenuCmd - creating menubar} { 31 catch {destroy .m1} 32 menu .m1 33 .m1 add cascade -label Test -menu "" 34 list [. configure -menu .m1] [. configure -menu ""] [destroy .m1] 35} {{} {} {}} 36test menu-1.6 {Tk_MenuCmd procedure menu ref no cascade} { 37 catch {destroy .t2} 38 catch {destroy .m1} 39 toplevel .t2 -menu .m1 40 wm geometry .t2 +0+0 41 list [catch {menu .m1} msg] $msg [destroy .m1 .t2] 42} {0 .m1 {}} 43test menu-1.7 {Tk_MenuCmd procedure one clone cascade} { 44 catch {destroy .m1} 45 catch {destroy .m2} 46 catch {destroy .t2} 47 toplevel .t2 -menu .m1 48 wm geometry .t2 +0+0 49 menu .m1 50 .m1 add cascade -menu .m2 51 list [catch {menu .m2} msg] $msg [destroy .t2 .m1 .m2] 52} {0 .m2 {}} 53test menu-1.8 {Tk_MenuCmd procedure two clone cascades} { 54 catch {destroy .m1} 55 catch {destroy .t2} 56 catch {destroy .t3} 57 catch {destroy .m2} 58 menu .m1 59 .m1 add cascade -menu .m2 60 toplevel .t2 -menu .m1 61 wm geometry .t2 +0+0 62 toplevel .t3 -menu .m1 63 wm geometry .t3 +0+0 64 list [catch {menu .m2} msg] $msg [destroy .t2 .t3 .m1 .m2] 65} {0 .m2 {}} 66test menu-1.9 {Tk_MenuCmd procedure two clone cascades different order} { 67 catch {destroy .t2} 68 catch {destroy .m1} 69 catch {destroy .t3} 70 catch {destroy .m2} 71 toplevel .t2 -menu .m1 72 wm geometry .t2 +0+0 73 menu .m1 74 .m1 add cascade -menu .m2 75 toplevel .t3 -menu .m1 76 wm geometry .t3 +0+0 77 list [catch {menu .m2} msg] $msg [destroy .t2 .t3 .m1 .m2] 78} {0 .m2 {}} 79test menu-1.10 {Tk_MenuCmd procedure two clone cascades menus last} { 80 catch {destroy .t2} 81 catch {destroy .t3} 82 catch {destroy .m1} 83 catch {destroy .m2} 84 toplevel .t2 -menu .m1 85 wm geometry .t2 +0+0 86 toplevel .t3 -menu .m1 87 wm geometry .t3 +0+0 88 menu .m1 89 .m1 add cascade -menu .m2 90 list [catch {menu .m2} msg] $msg [destroy .t2 .t3 .m1 .m2] 91} {0 .m2 {}} 92test menu-1.11 {Tk_MenuCmd procedure three clones cascades} { 93 catch {destroy .t2} 94 catch {destroy .t3} 95 catch {destroy .t4} 96 catch {destroy .m1} 97 catch {destroy .m2} 98 toplevel .t2 -menu .m1 99 wm geometry .t2 +0+0 100 toplevel .t3 -menu .m1 101 wm geometry .t3 +0+0 102 toplevel .t4 -menu .m1 103 wm geometry .t4 +0+0 104 menu .m1 105 .m1 add cascade -menu .m2 106 list [catch {menu .m2} msg] $msg [destroy .t2 .t3 .t4 .m1 .m2] 107} {0 .m2 {}} 108test menu-1.12 {Tk_MenuCmd procedure} { 109 catch {destroy .t2} 110 catch {destroy .m1} 111 toplevel .t2 -menu .m1 112 wm geometry .t2 +0+0 113 list [catch {menu .m1} msg] $msg [destroy .t2 .m1] 114} {0 .m1 {}} 115test menu-1.13 {Tk_MenuCmd procedure} { 116 catch {destroy .t2} 117 catch {destroy .t3} 118 catch {destroy .m1} 119 toplevel .t2 -menu .m1 120 wm geometry .t2 +0+0 121 toplevel .t3 -menu .m1 122 wm geometry .t3 +0+0 123 list [catch {menu .m1} msg] $msg [destroy .t2 .t3 .m1] 124} {0 .m1 {}} 125test menu-1.14 {Tk_MenuCmd procedure} { 126 catch {destroy .t2} 127 catch {destroy .t3} 128 catch {destroy .t4} 129 catch {destroy .m1} 130 toplevel .t2 -menu .m1 131 wm geometry .t2 +0+0 132 toplevel .t3 -menu .m1 133 wm geometry .t3 +0+0 134 toplevel .t4 -menu .m1 135 wm geometry .t4 +0+0 136 list [catch {menu .m1} msg] $msg [destroy .t2 .t3 .t4 .m1] 137} {0 .m1 {}} 138 139catch {destroy .m1} 140menu .m1 141set i 1 142foreach configTest { 143 {-activebackground #012345 #012345 non-existent 144 {unknown color name "non-existent"}} 145 {-activeborderwidth 1.3 1.3 badValue {bad screen distance "badValue"}} 146 {-activeforeground #ff0000 #ff0000 non-existent 147 {unknown color name "non-existent"}} 148 {-background #ff0000 #ff0000 non-existent 149 {unknown color name "non-existent"}} 150 {-bg #110022 #110022 bogus {unknown color name "bogus"}} 151 {-borderwidth 1.3 1.3 badValue {bad screen distance "badValue"}} 152 {-cursor arrow arrow badValue {bad cursor spec "badValue"}} 153 {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"}} 154 {-fg #110022 #110022 bogus {unknown color name "bogus"}} 155 {-font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* 156 -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* {} 157 {font "" doesn't exist}} 158 {-foreground #110022 #110022 bogus {unknown color name "bogus"}} 159 {-postcommand "any old string" "any old string" {} {}} 160 {-relief groove groove 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}} 161 {-selectcolor #110022 #110022 bogus {unknown color name "bogus"}} 162 {-takefocus "any string" "any string" {} {}} 163 {-tearoff 0 0} 164 {-tearoff 1 1} 165 {-tearoffcommand "any old string" "any old string" {} {}} 166} { 167 set name [lindex $configTest 0] 168 set value [lindex $configTest 1] 169 set result [lindex $configTest 2] 170 test menu-2.$i [list configuration options $name $value $result] { 171 .m1 configure $name $value 172 lindex [.m1 configure $name] 4 173 } $result 174 incr i 175 if {[lindex $configTest 3] != ""} { 176 set value [lindex $configTest 3] 177 set result [lindex $configTest 4] 178 test menu-2.$i [list configuration options $name $value $result] { 179 list [catch {.m1 configure $name $value} msg] $msg 180 } [list 1 $result] 181 } 182 .m1 configure $name [lindex [.m1 configure $name] 3] 183 incr i 184} 185destroy .m1 186 187# We need to test all of the options with all of the different types of 188# menu entries. The following code sets up .m1 with 6 items. It then 189# runs through the big table below it. 190# index 0 is tearoff, 1 command, 2 cascade, 3 separator, 4 checkbutton, 191# 5 radiobutton 192 193menu .m1 194.m1 add command -label "command" 195menu .m2 196.m2 add command -label "test" 197.m1 add cascade -label "cascade" -menu .m2 198.m1 add separator 199.m1 add checkbutton -label "checkbutton" -variable check -onvalue on -offvalue off 200.m1 add radiobutton -label "radiobutton" -variable radio 201image create photo image1 -file [file join $tk_library demos images earth.gif] 202 203foreach configTest { 204 {-activebackground 205 {{#012345 206 {{unknown option "-activebackground"} #012345 #012345 207 {unknown option "-activebackground"} #012345 #012345 208 } 209 } 210 {non-existent 211 {{unknown option "-activebackground"} 212 {unknown color name "non-existent"} 213 {unknown color name "non-existent"} 214 {unknown option "-activebackground"} 215 {unknown color name "non-existent"} 216 {unknown color name "non-existent"} 217 } 218 }} 219 } 220 {-activeforeground 221 {{#ff0000 222 {{unknown option "-activeforeground"} 223 #ff0000 #ff0000 {unknown option "-activeforeground"} #ff0000 #ff0000 224 } 225 } 226 {non-existent 227 {{unknown option "-activeforeground"} 228 {unknown color name "non-existent"} 229 {unknown color name "non-existent"} 230 {unknown option "-activeforeground"} 231 {unknown color name "non-existent"} 232 {unknown color name "non-existent"} 233 } 234 }} 235 } 236 {-accelerator 237 {{"Ctrl+S" 238 {{unknown option "-accelerator"} 239 "Ctrl+S" "Ctrl+S" {unknown option "-accelerator"} 240 "Ctrl+S" "Ctrl+S" 241 } 242 }} 243 } 244 {-background 245 {{#ff0000 246 {#ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000 247 } 248 } 249 {non-existent 250 {{unknown color name "non-existent"} 251 {unknown color name "non-existent"} 252 {unknown color name "non-existent"} 253 {unknown color name "non-existent"} 254 {unknown color name "non-existent"} 255 {unknown color name "non-existent"} 256 } 257 }} 258 } 259 {-bitmap 260 {{questhead 261 {{unknown option "-bitmap"} questhead questhead 262 {unknown option "-bitmap"} questhead questhead 263 } 264 } 265 {badValue 266 {{unknown option "-bitmap"} 267 {bitmap "badValue" not defined} 268 {bitmap "badValue" not defined} 269 {unknown option "-bitmap"} 270 {bitmap "badValue" not defined} 271 {bitmap "badValue" not defined} 272 } 273 }} 274 } 275 {-columnbreak 276 {{1 277 {{unknown option "-columnbreak"} 1 1 278 {unknown option "-columnbreak"} 1 1} 279 }} 280 } 281 {-command 282 {{beep 283 {{unknown option "-command"} beep beep 284 {unknown option "-command"} beep beep 285 } 286 }} 287 } 288 {-font 289 {{-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* 290 {{unknown option "-font"} 291 -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* 292 -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* 293 {unknown option "-font"} 294 -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* 295 -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* 296 } 297 } 298 {{kill rock stars} 299 {{unknown option "-font"} 300 {expected integer but got "rock"} 301 {expected integer but got "rock"} 302 {unknown option "-font"} 303 {expected integer but got "rock"} 304 {expected integer but got "rock"} 305 } 306 }} 307 } 308 {-foreground 309 {{#110022 310 {{unknown option "-foreground"} #110022 #110022 311 {unknown option "-foreground"} #110022 #110022 312 } 313 } 314 {non-existent 315 {{unknown option "-foreground"} 316 {unknown color name "non-existent"} 317 {unknown color name "non-existent"} 318 {unknown option "-foreground"} 319 {unknown color name "non-existent"} 320 {unknown color name "non-existent"} 321 } 322 }} 323 } 324 {-image 325 {{image1 326 {{unknown option "-image"} image1 image1 327 {unknown option "-image"} image1 image1 328 } 329 } 330 {bogus 331 {{unknown option "-image"} 332 {image "bogus" doesn't exist} 333 {image "bogus" doesn't exist} 334 {unknown option "-image"} 335 {image "bogus" doesn't exist} 336 {image "bogus" doesn't exist} 337 } 338 } 339 {"" 340 {{unknown option "-image"} 341 {} 342 {} 343 {unknown option "-image"} 344 {} 345 {} 346 } 347 }} 348 } 349 {-indicatoron 350 {{1 351 {{unknown option "-indicatoron"} 352 {unknown option "-indicatoron"} 353 {unknown option "-indicatoron"} 354 {unknown option "-indicatoron"} 1 1 355 } 356 }} 357 } 358 {-label 359 {{test 360 {{unknown option "-label"} test test 361 {unknown option "-label"} test test 362 } 363 }} 364 } 365 {-menu 366 {{.m2 367 {{unknown option "-menu"} 368 {unknown option "-menu"} .m2 369 {unknown option "-menu"} 370 {unknown option "-menu"} 371 {unknown option "-menu"} 372 } 373 }} 374 } 375 {-offvalue 376 {{off 377 {{unknown option "-offvalue"} 378 {unknown option "-offvalue"} 379 {unknown option "-offvalue"} 380 {unknown option "-offvalue"} 381 off 382 {unknown option "-offvalue"} 383 } 384 }} 385 } 386 {-onvalue 387 {{on 388 {{unknown option "-onvalue"} 389 {unknown option "-onvalue"} 390 {unknown option "-onvalue"} 391 {unknown option "-onvalue"} 392 on 393 {unknown option "-onvalue"} 394 } 395 }} 396 } 397 {-selectcolor 398 {{#110022 399 {{unknown option "-selectcolor"} 400 {unknown option "-selectcolor"} 401 {unknown option "-selectcolor"} 402 {unknown option "-selectcolor"} 403 #110022 404 #110022 405 } 406 } 407 {non-existent 408 {{unknown option "-selectcolor"} 409 {unknown option "-selectcolor"} 410 {unknown option "-selectcolor"} 411 {unknown option "-selectcolor"} 412 {unknown color name "non-existent"} 413 {unknown color name "non-existent"} 414 } 415 }} 416 } 417 {-selectimage 418 {{image1 419 {{unknown option "-selectimage"} 420 {unknown option "-selectimage"} 421 {unknown option "-selectimage"} 422 {unknown option "-selectimage"} image1 image1 423 } 424 } 425 {bogus 426 {{unknown option "-selectimage"} 427 {unknown option "-selectimage"} 428 {unknown option "-selectimage"} 429 {unknown option "-selectimage"} 430 {image "bogus" doesn't exist} 431 {image "bogus" doesn't exist} 432 } 433 } 434 {"" 435 {{unknown option "-selectimage"} 436 {unknown option "-selectimage"} 437 {unknown option "-selectimage"} 438 {unknown option "-selectimage"} 439 {} 440 {} 441 } 442 }} 443 } 444 {-state 445 {{normal 446 {normal normal normal {unknown option "-state"} normal normal 447 } 448 }} 449 } 450 {-value 451 {{"any string" 452 {{unknown option "-value"} 453 {unknown option "-value"} 454 {unknown option "-value"} 455 {unknown option "-value"} 456 {unknown option "-value"} "any string" 457 } 458 }} 459 } 460 {-variable 461 {{"any string" 462 {{unknown option "-variable"} 463 {unknown option "-variable"} 464 {unknown option "-variable"} 465 {unknown option "-variable"} 466 "any string" 467 "any string" 468 } 469 }} 470 } 471 {-underline 472 {{0 473 {{unknown option "-underline"} 0 0 474 {unknown option "-underline"} 0 0 475 } 476 } 477 {3p 478 {{unknown option "-underline"} 479 {expected integer but got "3p"} 480 {expected integer but got "3p"} 481 {unknown option "-underline"} 482 {expected integer but got "3p"} 483 {expected integer but got "3p"} 484 } 485 }} 486 } 487} { 488 set name [lindex $configTest 0] 489 foreach attempt [lindex $configTest 1] { 490 set value [lindex $attempt 0] 491 set options [lindex $attempt 1] 492 foreach item {0 1 2 3 4 5} { 493 catch {unset msg} 494 test menu-2.$i [list entry configuration options $name $item $value [.m1 type $item]] { 495 set result [catch {.m1 entryconfigure $item $name $value} msg] 496 if {$result == 1} { 497 set msg 498 } else { 499 lindex [.m1 entryconfigure $item $name] 4 500 } 501 } [lindex $options $item] 502 incr i 503 } 504 } 505} 506 507image delete image1 508destroy .m1 509destroy .m2 510 511test menu-3.1 {MenuWidgetCmd procedure} { 512 catch {destroy .m1} 513 menu .m1 514 list [catch {.m1} msg] $msg [destroy .m1] 515} {1 {wrong # args: should be ".m1 option ?arg arg ...?"} {}} 516test menu-3.2 {MenuWidgetCmd, Tcl_Preserve and Tcl_Release} {nonUnixUserInteraction } { 517 catch {destroy .m1} 518 menu .m1 -postcommand "destroy .m1" 519 .m1 add command -label "menu-3.2: Hit Escape" 520 list [catch {.m1 post 40 40} msg] $msg 521} {0 {}} 522test menu-3.3 {MenuWidgetCmd procedure, "activate" option} { 523 catch {destroy .m1} 524 menu .m1 525 .m1 add command -label "test" 526 list [catch {.m1 activate} msg] $msg [destroy .m1] 527} {1 {wrong # args: should be ".m1 activate index"} {}} 528test menu-3.4 {MenuWidgetCmd procedure, "activate" option} { 529 catch {destroy .m1} 530 menu .m1 531 list [catch {.m1 activate "foo"} msg] $msg [destroy .m1] 532} {1 {bad menu entry index "foo"} {}} 533test menu-3.5 {MenuWidgetCmd procedure, "activate" option} { 534 catch {destroy .m1} 535 menu .m1 536 .m1 add command -label "test" 537 .m1 add separator 538 list [catch {.m1 activate 2} msg] $msg [destroy .m1] 539} {0 {} {}} 540test menu-3.6 {MenuWidgetCmd procedure, "activate" option} { 541 catch {destroy .m1} 542 menu .m1 543 .m1 add command -label "test" 544 .m1 entryconfigure 1 -state disabled 545 list [catch {.m1 activate 1} msg] $msg [destroy .m1] 546} {0 {} {}} 547test menu-3.7 {MenuWidgetCmd procedure, "activate" option} { 548 catch {destroy .m1} 549 menu .m1 550 .m1 add command -label "test" 551 list [catch {.m1 activate 1} msg] $msg [destroy .m1] 552} {0 {} {}} 553test menu-3.8 {MenuWidgetCmd procedure, "add" option} { 554 catch {destroy .m1} 555 menu .m1 556 list [catch {.m1 add} msg] $msg [destroy .m1] 557} {1 {wrong # args: should be ".m1 add type ?options?"} {}} 558test menu-3.9 {MenuWidgetCmd procedure, "add" option} { 559 catch {destroy .m1} 560 menu .m1 561 list [catch {.m1 add foo} msg] $msg [destroy .m1] 562} {1 {bad menu entry type "foo": must be cascade, checkbutton, command, radiobutton, or separator} {}} 563test menu-3.10 {MenuWidgetCmd procedure, "add" option} { 564 catch {destroy .m1} 565 menu .m1 566 list [catch {.m1 add separator} msg] $msg [destroy .m1] 567} {0 {} {}} 568test menu-3.11 {MenuWidgetCmd procedure, "cget" option} { 569 catch {destroy .m1} 570 menu .m1 571 list [catch {.m1 cget} msg] $msg [destroy .m1] 572} {1 {wrong # args: should be ".m1 cget option"} {}} 573test menu-3.12 {MenuWidgetCmd procedure, "cget" option} { 574 catch {destroy .m1} 575 menu .m1 576 list [catch {.m1 cget -gorp} msg] $msg [destroy .m1] 577} {1 {unknown option "-gorp"} {}} 578test menu-3.13 {MenuWidgetCmd procedure, "cget" option} { 579 catch {destroy .m1} 580 menu .m1 581 .m1 configure -postcommand "Some string" 582 list [catch {.m1 cget -postcommand} msg] $msg [destroy .m1] 583} {0 {Some string} {}} 584test menu-3.14 {MenuWidgetCmd procedure, "clone" option} { 585 catch {destroy .m1} 586 menu .m1 587 list [catch {.m1 clone} msg] $msg [destroy .m1] 588} {1 {wrong # args: should be ".m1 clone newMenuName ?menuType?"} {}} 589test menu-3.15 {MenuWidgetCmd procedure, "clone" option} { 590 catch {destroy .m1} 591 menu .m1 592 list [catch {.m1 clone a b c d} msg] $msg [destroy .m1] 593} {1 {wrong # args: should be ".m1 clone newMenuName ?menuType?"} {}} 594test menu-3.16 {MenuWidgetCmd procedure, "clone" option} { 595 catch {destroy .m1} 596 menu .m1 597 list [catch {.m1 clone .m1.clone1} msg] $msg [destroy .m1] 598} {0 {} {}} 599test menu-3.17 {MenuWidgetCmd procedure, "clone" option} { 600 catch {destroy .m1} 601 menu .m1 602 list [catch {.m1 clone .m1.clone1 tearoff} msg] $msg [destroy .m1] 603} {0 {} {}} 604test menu-3.18 {MenuWidgetCmd procedure, "configure" option} { 605 catch {destroy .m1} 606 menu .m1 607 list [catch {llength [.m1 configure]} msg] $msg [destroy .m1] 608} {0 20 {}} 609test menu-3.19 {MenuWidgetCmd procedure, "configure" option} { 610 catch {destroy .m1} 611 menu .m1 612 list [catch {.m1 configure -gorp} msg] $msg [destroy .m1] 613} {1 {unknown option "-gorp"} {}} 614test menu-3.20 {MenuWidgetCmd procedure, "configure" option} { 615 catch {destroy .m1} 616 menu .m1 617 list [catch {.m1 configure -postcommand "A random String"} msg] $msg [destroy .m1] 618} {0 {} {}} 619test menu-3.21 {MenuWidgetCmd procedure, "configure" option} { 620 catch {destroy .m1} 621 menu .m1 622 .m1 configure -postcommand "Another string" 623 list [catch {lindex [.m1 configure -postcommand] 4} msg] $msg [destroy .m1] 624} {0 {Another string} {}} 625test menu-3.22 {MenuWidgetCmd procedure, "delete" option} { 626 catch {destroy .m1} 627 menu .m1 628 list [catch {.m1 delete} msg] $msg [destroy .m1] 629} {1 {wrong # args: should be ".m1 delete first ?last?"} {}} 630test menu-3.23 {MenuWidgetCmd procedure, "delete" option} { 631 catch {destroy .m1} 632 menu .m1 633 list [catch {.m1 delete foo} msg] $msg [destroy .m1] 634} {1 {bad menu entry index "foo"} {}} 635test menu-3.24 {MenuWidgetCmd procedure, "delete" option} { 636 catch {destroy .m1} 637 menu .m1 638 list [catch {.m1 delete 0 "foo"} msg] $msg [destroy .m1] 639} {1 {bad menu entry index "foo"} {}} 640test menu-3.25 {MenuWidgetCmd procedure, "delete" option} { 641 catch {destroy .m1} 642 menu .m1 643 list [catch {.m1 delete 0} msg] $msg [destroy .m1] 644} {0 {} {}} 645test menu-3.26 {MenuWidgetCmd procedure, "delete" option} { 646 catch {destroy .m1} 647 menu .m1 648 .m1 add command -label "foo" 649 list [catch {.m1 delete 1 0} msg] $msg [destroy .m1] 650} {0 {} {}} 651test menu-3.27 {MenuWidgetCmd procedure, "delete" option} { 652 catch {destroy .m1} 653 menu .m1 654 .m1 add command -label "1" 655 .m1 add command -label "2" 656 .m1 add command -label "3" 657 list [catch {.m1 delete 1 3} msg] $msg [destroy .m1] 658} {0 {} {}} 659test menu-3.28 {MenuWidgetCmd procedure, "delete" option} { 660 catch {destroy .m1} 661 menu .m1 662 .m1 add command -label "1" 663 .m1 add command -label "2" 664 .m1 add command -label "3" 665 .m1 activate 2 666 list [catch {.m1 delete 1 3} msg] $msg [destroy .m1] 667} {0 {} {}} 668test menu-3.29 {MenuWidgetCmd procedure, "delete" option} { 669 catch {destroy .m1} 670 menu .m1 671 .m1 add command -label "1" 672 .m1 add command -label "2" 673 .m1 add command -label "3" 674 .m1 activate 3 675 list [catch {.m1 delete 1} msg] $msg [destroy .m1] 676} {0 {} {}} 677test menu-3.30 {MenuWidgetCmd procedure, "entrycget" option} { 678 catch {destroy .m1} 679 menu .m1 680 list [catch {.m1 entrycget} msg] $msg [destroy .m1] 681} {1 {wrong # args: should be ".m1 entrycget index option"} {}} 682test menu-3.31 {MenuWidgetCmd procedure, "entrycget" option} { 683 catch {destroy .m1} 684 menu .m1 685 list [catch {.m1 entrycget index option foo} msg] $msg [destroy .m1] 686} {1 {wrong # args: should be ".m1 entrycget index option"} {}} 687test menu-3.32 {MenuWidgetCmd procedure, "entrycget" option} { 688 catch {destroy .m1} 689 menu .m1 690 list [catch {.m1 entrycget foo -label} msg] $msg [destroy .m1] 691} {1 {bad menu entry index "foo"} {}} 692test menu-3.33 {MenuWidgetCmd procedure, "entrycget" option} { 693 catch {destroy .m1} 694 menu .m1 695 .m1 add command -label "test" 696 list [catch {.m1 entrycget 1 -label} msg] $msg [destroy .m1] 697} {0 test {}} 698test menu-3.34 {MenuWidgetCmd procedure, "entryconfigure" option} { 699 catch {destroy .m1} 700 menu .m1 701 list [catch {.m1 entryconfigure} msg] $msg [destroy .m1] 702} {1 {wrong # args: should be ".m1 entryconfigure index ?option value ...?"} {}} 703test menu-3.35 {MenuWidgetCmd procedure, "entryconfigure" option} { 704 catch {destroy .m1} 705 menu .m1 706 list [catch {.m1 entryconfigure foo} msg] $msg [destroy .m1] 707} {1 {bad menu entry index "foo"} {}} 708test menu-3.36 {MenuWidgetCmd procedure, "entryconfigure" option} { 709 catch {destroy .m1} 710 menu .m1 711 .m1 add command -label "test" 712 list [catch {llength [.m1 entryconfigure 1]} msg] $msg [destroy .m1] 713} {0 15 {}} 714test menu-3.37 {MenuWidgetCmd procedure, "entryconfigure" option} { 715 catch {destroy .m1} 716 menu .m1 717 .m1 add command -label "test" 718 list [catch {lindex [.m1 entryconfigure 1 -label] 4} msg] $msg [destroy .m1] 719} {0 test {}} 720test menu-3.38 {MenuWidgetCmd procedure, "entryconfigure" option} { 721 catch {destroy .m1} 722 menu .m1 723 .m1 add command -label "test" 724 .m1 entryconfigure 1 -label "changed" 725 list [catch {lindex [.m1 entryconfigure 1 -label] 4} msg] $msg [destroy .m1] 726} {0 changed {}} 727test menu-3.39 {MenuWidgetCmd procedure, "index" option} { 728 catch {destroy .m1} 729 menu .m1 730 list [catch {.m1 index} msg] $msg [destroy .m1] 731} {1 {wrong # args: should be ".m1 index string"} {}} 732test menu-3.40 {MenuWidgetCmd procedure, "index" option} { 733 catch {destroy .m1} 734 menu .m1 735 list [catch {.m1 index foo} msg] $msg [destroy .m1] 736} {1 {bad menu entry index "foo"} {}} 737test menu-3.41 {MenuWidgetCmd procedure, "index" option} { 738 catch {destroy .m1} 739 menu .m1 740 .m1 add command -label "test" 741 list [catch {.m1 index "test"} msg] $msg [destroy .m1] 742} {0 1 {}} 743test menu-3.42 {MenuWidgetCmd procedure, "insert" option} { 744 catch {destroy .m1} 745 menu .m1 746 list [catch {.m1 insert} msg] $msg [destroy .m1] 747} {1 {wrong # args: should be ".m1 insert index type ?options?"} {}} 748test menu-3.43 {MenuWidgetCmd procedure, "insert" option} { 749 catch {destroy .m1} 750 menu .m1 751 .m1 insert 1 command -label "test" 752 list [catch {.m1 entrycget 1 -label} msg] $msg [destroy .m1] 753} {0 test {}} 754test menu-3.44 {MenuWidgetCmd procedure, "invoke" option} { 755 catch {destroy .m1} 756 menu .m1 757 list [catch {.m1 invoke} msg] $msg [destroy .m1] 758} {1 {wrong # args: should be ".m1 invoke index"} {}} 759test menu-3.45 {MenuWidgetCmd procedure, "invoke" option} { 760 catch {destroy .m1} 761 menu .m1 762 list [catch {.m1 invoke foo} msg] $msg [destroy .m1] 763} {1 {bad menu entry index "foo"} {}} 764test menu-3.46 {MenuWidgetCmd procedure, "invoke" option} { 765 catch {destroy .m1} 766 catch {unset foo} 767 menu .m1 768 .m1 add command -label "set foo" -command "set foo hello" 769 list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] 770} {0 hello 0 hello 0 {} {}} 771test menu-3.47 {MenuWidgetCmd procedure, "post" option} { 772 catch {destroy .m1} 773 menu .m1 774 .m1 add command -label "On Windows, hit Escape to get this menu to go away" 775 list [catch {.m1 post} msg] $msg [destroy .m1] 776} {1 {wrong # args: should be ".m1 post x y"} {}} 777test menu-3.48 {MenuWidgetCmd procedure, "post" option} { 778 catch {destroy .m1} 779 menu .m1 780 list [catch {.m1 post foo 40} msg] $msg [destroy .m1] 781} {1 {expected integer but got "foo"} {}} 782test menu-3.49 {MenuWidgetCmd procedure, "post" option} { 783 catch {destroy .m1} 784 menu .m1 785 list [catch {.m1 post 40 bar} msg] $msg [destroy .m1] 786} {1 {expected integer but got "bar"} {}} 787test menu-3.50 {MenuWidgetCmd procedure, "post" option} {nonUnixUserInteraction } { 788 catch {destroy .m1} 789 menu .m1 790 .m1 add command -label "menu-3.53: hit Escape" -command "puts hello" 791 list [catch {.m1 post 40 40} msg] $msg [destroy .m1] 792} {0 {} {}} 793test menu-3.51 {MenuWidgetCmd procedure, "postcascade" option} { 794 catch {destroy .m1} 795 menu .m1 796 list [catch {.m1 postcascade} msg] $msg [destroy .m1] 797} {1 {wrong # args: should be ".m1 postcascade index"} {}} 798test menu-3.52 {MenuWidgetCmd procedure, "postcascade" option} { 799 catch {destroy .m1} 800 menu .m1 801 list [catch {.m1 postcascade foo} msg] $msg [destroy .m1] 802} {1 {bad menu entry index "foo"} {}} 803test menu-3.53 {MenuWidgetCmd procedure, "postcascade" option} {nonUnixUserInteraction } { 804 catch {destroy .m1} 805 catch {destroy .m2} 806 menu .m1 807 .m1 add command -label "menu-3.56 - hit Escape" 808 menu .m2 809 .m1 post 40 40 810 .m1 add cascade -menu .m2 811 list [catch {.m1 postcascade 1} msg] $msg [destroy .m1 .m2] 812} {0 {} {}} 813test menu-3.54 {MenuWidgetCmd procedure, "postcascade" option} { 814 catch {destroy .m1} 815 catch {destroy .m2} 816 menu .m1 817 menu .m2 818 .m1 add cascade -menu .m2 -label "menu-3.57 - hit Escape" 819 .m1 postcascade 1 820 list [catch {.m1 postcascade none} msg] $msg [destroy .m1 .m2] 821} {0 {} {}} 822test menu-3.55 {MenuWidgetCmd procedure, "type" option} { 823 catch {destroy .m1} 824 menu .m1 825 list [catch {.m1 type} msg] $msg [destroy .m1] 826} {1 {wrong # args: should be ".m1 type index"} {}} 827test menu-3.56 {MenuWidgetCmd procedure, "type" option} { 828 catch {destroy .m1} 829 menu .m1 830 list [catch {.m1 type foo} msg] $msg [destroy .m1] 831} {1 {bad menu entry index "foo"} {}} 832test menu-3.57 {MenuWidgetCmd procedure, "type" option} { 833 catch {destroy .m1} 834 menu .m1 835 .m1 add command -label "test" 836 list [catch {.m1 type 1} msg] $msg [destroy .m1] 837} {0 command {}} 838test menu-3.58 {MenuWidgetCmd procedure, "type" option} { 839 catch {destroy .m1} 840 menu .m1 841 .m1 add separator 842 list [catch {.m1 type 1} msg] $msg [destroy .m1] 843} {0 separator {}} 844test menu-3.59 {MenuWidgetCmd procedure, "type" option} { 845 catch {destroy .m1} 846 menu .m1 847 .m1 add checkbutton -label "test" 848 list [catch {.m1 type 1} msg] $msg [destroy .m1] 849} {0 checkbutton {}} 850test menu-3.60 {MenuWidgetCmd procedure, "type" option} { 851 catch {destroy .m1} 852 menu .m1 853 .m1 add radiobutton -label "test" 854 list [catch {.m1 type 1} msg] $msg [destroy .m1] 855} {0 radiobutton {}} 856test menu-3.61 {MenuWidgetCmd procedure, "type" option} { 857 catch {destroy .m1} 858 menu .m1 859 .m1 add cascade -label "test" 860 list [catch {.m1 type 1} msg] $msg [destroy .m1] 861} {0 cascade {}} 862test menu-3.62 {MenuWidgetCmd procedure, "type" option} { 863 catch {destroy .m1} 864 menu .m1 865 list [catch {.m1 type 0} msg] $msg [destroy .m1] 866} {0 tearoff {}} 867test menu-3.63 {MenuWidgetCmd procedure, "unpost" option} { 868 catch {destroy .m1} 869 menu .m1 870 list [catch {.m1 unpost foo} msg] $msg [destroy .m1] 871} {1 {wrong # args: should be ".m1 unpost"} {}} 872test menu-3.64 {MenuWidgetCmd procedure, "unpost" option} {nonUnixUserInteraction } { 873 catch {destroy .m1} 874 menu .m1 875 .m1 add command -label "menu-3.68 - hit Escape" 876 .m1 post 40 40 877 list [catch {.m1 unpost} msg] $msg [destroy .m1] 878} {0 {} {}} 879test menu-3.65 {MenuWidgetCmd procedure, "yposition" option} { 880 catch {destroy .m1} 881 menu .m1 882 list [catch {.m1 yposition} msg] $msg [destroy .m1] 883} {1 {wrong # args: should be ".m1 yposition index"} {}} 884test menu-3.66 {MenuWidgetCmd procedure, "yposition" option} { 885 catch {destroy .m1} 886 menu .m1 887 list [catch {.m1 yposition 1}] [destroy .m1] 888} {0 {}} 889test menu-3.67 {MenuWidgetCmd procedure, bad option} { 890 catch {destroy .m1} 891 menu .m1 892 list [catch {.m1 foo} msg] $msg [destroy .m1] 893} {1 {bad option "foo": must be activate, add, cget, clone, configure, delete, entrycget, entryconfigure, index, insert, invoke, post, postcascade, type, unpost, or yposition} {}} 894test menu-3.68 {MenuWidgetCmd procedure, fix for bug#508988} { 895 set t .t 896 set m1 .t.m1 897 set c1 .t.c1 898 set c2 .t.c2 899 toplevel .t 900 menu $m1 -tearoff 1 901 menu $c1 -tearoff 1 902 $c1 add command -label c1 903 menu $c2 -tearoff 1 904 $c2 add command -label c2 905 $m1 add cascade -label c1 -menu $c1 906 $t configure -menu $m1 907 $m1 entryconfigure 1 -menu $c2 -label c2 908 $t configure -menu "" 909 set l [list [winfo exists $c1] [winfo exists $c2]] 910 destroy $t; 911 set l; 912} {1 1} 913 914test menu-4.1 {TkInvokeMenu: disabled} { 915 catch {destroy .m1} 916 catch {unset foo} 917 menu .m1 918 .m1 add checkbutton -label "test" -variable foo -onvalue on -offvalue off \ 919 -state disabled 920 list [catch {.m1 invoke 1} msg] [destroy .m1] $foo 921} {0 {} off} 922test menu-4.2 {TkInvokeMenu: tearoff} { 923 catch {destroy .m1} 924 menu .m1 925 list [catch {.m1 invoke 0} msg] [destroy .m1] 926} {0 {}} 927test menu-4.3 {TkInvokeMenu: checkbutton -on} { 928 catch {destroy .m1} 929 catch {unset foo} 930 menu .m1 931 .m1 add checkbutton -label "test" -variable foo -onvalue on -offvalue off 932 list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] 933} {0 {} 0 on 0 {} {}} 934test menu-4.4 {TkInvokeMenu: checkbutton -off} { 935 catch {destroy .m1} 936 catch {unset foo} 937 menu .m1 938 .m1 add checkbutton -label "test" -variable foo -onvalue on -offvalue off 939 .m1 invoke 1 940 list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] 941} {0 {} 0 off 0 {} {}} 942test menu-4.5 {TkInvokeMenu: checkbutton array element} { 943 catch {destroy .m1} 944 catch {unset foo} 945 menu .m1 946 .m1 add checkbutton -label "test" -variable foo(1) -onvalue on 947 list [catch {.m1 invoke 1} msg] $msg [catch {set foo(1)} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] 948} {0 {} 0 on 0 {} {}} 949test menu-4.6 {TkInvokeMenu: radiobutton} { 950 catch {destroy .m1} 951 catch {unset foo} 952 menu .m1 953 .m1 add radiobutton -label "1" -variable foo -value one 954 .m1 add radiobutton -label "2" -variable foo -value two 955 .m1 add radiobutton -label "3" -variable foo -value three 956 list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] 957} {0 {} 0 one 0 {} {}} 958test menu-4.7 {TkInvokeMenu: radiobutton} { 959 catch {destroy .m1} 960 catch {unset foo} 961 menu .m1 962 .m1 add radiobutton -label "1" -variable foo -value one 963 .m1 add radiobutton -label "2" -variable foo -value two 964 .m1 add radiobutton -label "3" -variable foo -value three 965 list [catch {.m1 invoke 2} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] 966} {0 {} 0 two 0 {} {}} 967test menu-4.8 {TkInvokeMenu: radiobutton} { 968 catch {destroy .m1} 969 catch {unset foo} 970 menu .m1 971 .m1 add radiobutton -label "1" -variable foo -value one 972 .m1 add radiobutton -label "2" -variable foo -value two 973 .m1 add radiobutton -label "3" -variable foo -value three 974 list [catch {.m1 invoke 3} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] 975} {0 {} 0 three 0 {} {}} 976test menu-4.9 {TkInvokeMenu: radiobutton array element} { 977 catch {destroy .m1} 978 catch {unset foo} 979 menu .m1 980 .m1 add radiobutton -label "1" -variable foo(2) -value one 981 .m1 add radiobutton -label "2" -variable foo(2) -value two 982 .m1 add radiobutton -label "3" -variable foo(2) -value three 983 list [catch {.m1 invoke 3} msg] $msg [catch {set foo(2)} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] 984} {0 {} 0 three 0 {} {}} 985test menu-4.10 {TkInvokeMenu} { 986 catch {destroy .m1} 987 catch {unset menu_test} 988 menu .m1 989 .m1 add command -label "test" -command "set menu_test menu-4.8" 990 list [catch {.m1 invoke 1} msg] $msg [catch {set menu_test} msg2] $msg2 [catch {unset menu_test} msg3] $msg3 [destroy .m1] 991} {0 menu-4.8 0 menu-4.8 0 {} {}} 992test menu-4.11 {TkInvokeMenu} { 993 catch {destroy .m1} 994 menu .m1 995 .m1 add cascade -label "test" -menu .m1.m2 996 list [catch {.m1 invoke 1} msg] $msg [destroy .m1] 997} {0 {} {}} 998test menu-4.12 {TkInvokeMenu} { 999 catch {destroy .m1} 1000 menu .m1 1001 .m1 add command -label "test" -command ".m1 delete 1" 1002 list [catch {.m1 invoke 1} msg] $msg [catch {.m1 type "test"} msg2] $msg2 [destroy .m1] 1003} {0 {} 1 {bad menu entry index "test"} {}} 1004 1005test menu-5.1 {DestroyMenuInstance} { 1006 catch {destroy .m1} 1007 menu .m1 1008 list [catch {destroy .m1} msg] $msg 1009} {0 {}} 1010test menu-5.2 {DestroyMenuInstance - cascade menu} { 1011 catch {destroy .m1} 1012 catch {destroy .m2} 1013 menu .m1 1014 .m1 add cascade -menu .m2 1015 menu .m2 1016 list [catch {destroy .m2} msg] $msg [destroy .m1] 1017} {0 {} {}} 1018test menu-5.3 {DestroyMenuInstance - multiple cascade parents} { 1019 catch {destroy .m1} 1020 catch {destroy .m2} 1021 catch {destroy .m3} 1022 menu .m1 1023 .m1 add cascade -menu .m3 1024 menu .m2 1025 .m2 add cascade -menu .m3 1026 menu .m3 1027 list [catch {destroy .m3} msg] $msg [destroy .m1 .m2] 1028} {0 {} {}} 1029test menu-5.4 {DestroyMenuInstance - multiple cascade parents} { 1030 catch {destroy .m1} 1031 catch {destroy .m2} 1032 catch {destroy .m3} 1033 catch {destroy .m4} 1034 menu .m1 1035 .m1 add cascade -menu .m4 1036 menu .m2 1037 .m2 add cascade -menu .m4 1038 menu .m3 1039 .m3 add cascade -menu .m4 1040 menu .m4 1041 list [catch {destroy .m4} msg] $msg [destroy .m1 .m2 .m3] 1042} {0 {} {}} 1043test menu-5.5 {DestroyMenuInstance - cascades of cloned menus} { 1044 catch {destroy .m1} 1045 catch {destroy .m2} 1046 menu .m1 1047 menu .m2 1048 .m1 add cascade -menu .m2 1049 . configure -menu .m1 1050 list [catch {destroy .m2} msg] $msg [.m1 entrycget 1 -menu] [. configure -menu ""] [destroy .m1] 1051} {0 {} .m2 {} {}} 1052test menu-5.6 {DestroyMenuInstance - cascades of cloned menus} { 1053 catch {destroy .m1} 1054 catch {destroy .m2} 1055 catch {destroy .t2} 1056 menu .m1 1057 .m1 add cascade -menu .m2 1058 menu .m2 1059 . configure -menu .m1 1060 toplevel .t2 1061 wm geometry .t2 +0+0 1062 .t2 configure -menu .m1 1063 list [catch {destroy .m2} msg] $msg [. configure -menu ""] [destroy .t2 .m1] 1064} {0 {} {} {}} 1065test menu-5.7 {DestroyMenuInstance - basic clones} { 1066 catch {destroy .m1} 1067 menu .m1 1068 set tearoff [tk::TearOffMenu .m1] 1069 list [catch {destroy $tearoff} msg] $msg [destroy .m1] 1070} {0 {} {}} 1071test menu-5.8 {DestroyMenuInstance - multiple clones} { 1072 catch {destroy .m1} 1073 menu .m1 1074 set tearoff1 [tk::TearOffMenu .m1] 1075 set tearoff2 [tk::TearOffMenu .m1] 1076 list [catch {destroy $tearoff1} msg] $msg [destroy .m1] 1077} {0 {} {}} 1078test menu-5.9 {DestroyMenuInstace - master menu} { 1079 catch {destroy .m1} 1080 menu .m1 1081 tk::TearOffMenu .m1 1082 list [catch {destroy .m1} msg] $msg 1083} {0 {}} 1084test menu-5.10 {DestroyMenuInstance - freeing entries} { 1085 catch {destroy .m1} 1086 menu .m1 1087 .m1 add command -label "foo" 1088 list [catch {destroy .m1} msg] $msg 1089} {0 {}} 1090test menu-5.11 {DestroyMenuInstace - no entries} { 1091 catch {destroy .m1} 1092 menu .m1 1093 .m1 configure -tearoff 0 1094 list [catch {destroy .m1} msg] $msg 1095} {0 {}} 1096test menu-5.12 {DestroyMenuInstance - platform data} { 1097 catch {destroy .m1} 1098 menu .m1 1099 list [catch {destroy .m1} msg] $msg 1100} {0 {}} 1101test menu-5.13 {DestroyMenuInstance - clones when mismatched tearoffs} { 1102 catch {destroy .m1} 1103 catch {destroy .m2} 1104 menu .m1 1105 menu .m2 1106 .m1 add cascade -menu .m2 1107 set tearoff [tk::TearOffMenu .m1 40 40] 1108 list [destroy .m2] [destroy .m1] 1109} {{} {}} 1110 1111test menu-6.1 {TkDestroyMenu} { 1112 catch {destroy .m1} 1113 menu .m1 1114 list [catch {destroy .m1} msg] $msg 1115} {0 {}} 1116test menu-6.2 {TkDestroyMenu - reentrancy} { 1117 catch {destroy .m1} 1118 catch {destroy .m2} 1119 menu .m1 1120 bind .m1 <Destroy> {destroy .m1} 1121 menu .m2 1122 bind .m2 <Destroy> {destroy .m2} 1123 list [catch {destroy .m1} msg] $msg [destroy .m2] 1124} {0 {} {}} 1125test menu-6.3 {TkDestroyMenu - reentrancy} { 1126 catch {destroy .m1} 1127 catch {destroy .m2} 1128 catch {destroy .m3} 1129 menu .m1 1130 bind .m1 <Destroy> {destroy .m2} 1131 .m1 clone .m2 1132 .m1 clone .m3 1133 list [catch {destroy .m1} msg] $msg [winfo exists .m2] 1134} {0 {} 0} 1135test menu-6.4 {TkDestroyMenu - reentrancy - clones} { 1136 catch {destroy .m1} 1137 catch {destroy .m2} 1138 menu .m1 1139 .m1 clone .m2 1140 .m1 clone .m1.m3 1141 list [catch {destroy .m1} msg] $msg 1142} {0 {}} 1143test menu-6.5 {TkDestroyMenu} { 1144 catch {destroy .m1} 1145 catch {destroy .m2} 1146 menu .m1 1147 .m1 clone .m2 1148 destroy .m1 1149 winfo exists .m2 1150} {0} 1151test menu-6.6 {TkDestroyMenu} { 1152 catch {destroy .m1} 1153 catch {destroy .m2} 1154 menu .m1 1155 .m1 clone .m2 tearoff 1156 list [catch {destroy .m1} msg] $msg 1157} {0 {}} 1158test menu-6.7 {TkDestroyMenu} { 1159 catch {destroy .m1} 1160 catch {destroy .m2} 1161 menu .m1 1162 .m1 clone .m2 1163 destroy .m2 1164 list [catch {destroy .m1} msg] $msg 1165} {0 {}} 1166test menu-6.8 {TkDestroyMenu} { 1167 catch {destroy .m1} 1168 catch {destroy .m2} 1169 catch {destroy .m3} 1170 menu .m1 1171 .m1 clone .m2 1172 .m1 clone .m3 1173 destroy .m1 1174 list [winfo exists .m2] [winfo exists .m3] 1175} {0 0} 1176test menu-6.9 {TkDestroyMenu} { 1177 catch {destroy .m1} 1178 catch {destroy .m2} 1179 catch {destroy .m3} 1180 menu .m1 1181 .m1 clone .m2 1182 .m1 clone .m3 1183 list [catch {destroy .m2} msg] $msg [catch {destroy .m3} msg2] $msg2 [catch {destroy .m1} msg3] $msg3 1184} {0 {} 0 {} 0 {}} 1185test menu-6.10 {TkDestroyMenu} { 1186 catch {destroy .m1} 1187 catch {destroy .m2} 1188 catch {destroy .m3} 1189 menu .m1 1190 .m1 clone .m2 1191 .m1 clone .m3 1192 list [catch {destroy .m3} msg] $msg [catch {destroy .m1} msg2] $msg2 1193} {0 {} 0 {}} 1194test menu-6.11 {TkDestroyMenu} { 1195 catch {destroy .m1} 1196 catch {destroy .m2} 1197 catch {destroy .m3} 1198 catch {destroy .m4} 1199 menu .m1 1200 .m1 clone .m2 1201 .m1 clone .m3 1202 .m1 clone .m4 1203 list [catch {destroy .m2} msg1] $msg1 [catch {destroy .m1} msg2] $msg2 1204} {0 {} 0 {}} 1205test menu-6.12 {TkDestroyMenu} { 1206 catch {destroy .m1} 1207 catch {destroy .m2} 1208 catch {destroy .m3} 1209 catch {destroy .m4} 1210 menu .m1 1211 .m1 clone .m2 1212 .m1 clone .m3 1213 .m1 clone .m4 1214 list [catch {destroy .m3} msg1] $msg1 [catch {destroy .m1} msg2] $msg2 1215} {0 {} 0 {}} 1216test menu-6.13 {TkDestroyMenu} { 1217 catch {destroy .m1} 1218 catch {destroy .m2} 1219 catch {destroy .m3} 1220 catch {destroy .m4} 1221 menu .m1 1222 .m1 clone .m2 1223 .m1 clone .m3 1224 .m1 clone .m4 1225 list [catch {destroy .m4} msg1] $msg1 [catch {destroy .m1} msg2] $msg2 1226} {0 {} 0 {}} 1227test menu-6.14 {TkDestroyMenu} { 1228 catch {destroy .m1} 1229 menu .m1 1230 . configure -menu .m1 1231 list [catch {destroy .m1} msg] $msg [. configure -menu ""] 1232} {0 {} {}} 1233test menu-6.15 {TkDestroyMenu} { 1234 catch {destroy .m1} 1235 catch {destroy .t2} 1236 menu .m1 1237 toplevel .t2 1238 wm geometry .t2 +0+0 1239 . configure -menu .m1 1240 .t2 configure -menu .m1 1241 list [catch {destroy .m1} msg] $msg [destroy .t2] [. configure -menu ""] 1242} {0 {} {} {}} 1243test menu-6.16 {TkDestroyMenu} { 1244 catch {destroy .m1} 1245 catch {destroy .t2} 1246 catch {destroy .t3} 1247 menu .m1 1248 toplevel .t2 1249 wm geometry .t2 +0+0 1250 toplevel .t3 1251 wm geometry .t3 +0+0 1252 . configure -menu .m1 1253 .t2 configure -menu .m1 1254 .t3 configure -menu .m1 1255 list [catch {destroy .m1} msg] $msg [destroy .t2] [destroy .t3] [. configure -menu ""] 1256} {0 {} {} {} {}} 1257 1258test menu-7.1 {UnhookCascadeEntry} { 1259 catch {destroy .m1} 1260 menu .m1 1261 .m1 add command -label "test" 1262 list [catch {destroy .m1} msg] $msg 1263} {0 {}} 1264test menu-7.2 {UnhookCascadeEntry} { 1265 catch {destroy .m1} 1266 menu .m1 1267 .m1 add cascade -menu .m2 1268 list [catch {destroy .m1} msg] $msg 1269} {0 {}} 1270test menu-7.3 {UnhookCascadeEntry} { 1271 catch {destroy .m1} 1272 catch {destroy .m2} 1273 menu .m1 1274 menu .m2 1275 .m2 add cascade -menu .cascade 1276 .m1 add cascade -menu .cascade 1277 list [catch {destroy .m1} msg] $msg [destroy .m2] 1278} {0 {} {}} 1279test menu-7.4 {UnhookCascadeEntry} { 1280 catch {destroy .m1} 1281 catch {destroy .m2} 1282 menu .m1 1283 menu .m2 1284 .m1 add cascade -menu .cascade 1285 .m2 add cascade -menu .cascade 1286 list [catch {destroy .m1} msg] $msg [destroy .m2] 1287} {0 {} {}} 1288test menu-7.5 {UnhookCascadeEntry} { 1289 catch {destroy .m1} 1290 catch {destroy .m2} 1291 catch {destroy .m3} 1292 menu .m1 1293 menu .m2 1294 menu .m3 1295 .m1 add cascade -menu .cascade 1296 .m2 add cascade -menu .cascade 1297 .m3 add cascade -menu .cascade 1298 list [catch {destroy .m1} msg] $msg [destroy .m2 .m3] 1299} {0 {} {}} 1300test menu-7.6 {UnhookCascadeEntry} { 1301 catch {destroy .m1} 1302 catch {destroy .m2} 1303 catch {destroy .m3} 1304 menu .m1 1305 menu .m2 1306 menu .m3 1307 .m1 add cascade -menu .cascade 1308 .m2 add cascade -menu .cascade 1309 .m3 add cascade -menu .cascade 1310 list [catch {destroy .m2} msg] $msg [destroy .m1 .m3] 1311} {0 {} {}} 1312test menu-7.7 {UnhookCascadeEntry} { 1313 catch {destroy .m1} 1314 catch {destroy .m2} 1315 catch {destroy .m3} 1316 menu .m1 1317 menu .m2 1318 menu .m3 1319 .m1 add cascade -menu .cascade 1320 .m2 add cascade -menu .cascade 1321 .m3 add cascade -menu .cascade 1322 list [catch {destroy .m3} msg] $msg [destroy .m1 .m2] 1323} {0 {} {}} 1324test menu-7.8 {UnhookCascadeEntry} { 1325 catch {destroy .m1} 1326 catch {destroy .m2} 1327 menu .m1 1328 menu .m2 1329 .m1 add cascade -menu .m2 1330 list [catch {destroy .m1} msg] $msg [destroy .m2] 1331} {0 {} {}} 1332test menu-7.9 {UnhookCascadeEntry} { 1333 catch {destroy .m1} 1334 catch {destroy .m2} 1335 menu .m1 1336 menu .m2 1337 .m1 add cascade -menu .m2 1338 destroy .m1 1339 list [catch {destroy .m2} msg] $msg 1340} {0 {}} 1341 1342test menu-8.1 {DestroyMenuEntry} { 1343 catch {destroy .m1} 1344 catch {destroy .m2} 1345 menu .m1 1346 menu .m2 1347 .m1 add cascade -menu .m2 1348 list [catch {.m1 delete 1} msg] $msg [destroy .m1 .m2] 1349} {0 {} {}} 1350test menu-8.2 {DestroyMenuEntry} { 1351 catch {image delete image1a} 1352 catch {destroy .m1} 1353 image create photo image1a -file [file join $tk_library demos images earth.gif] 1354 menu .m1 1355 .m1 add command -image image1a 1356 list [catch {.m1 delete 1} msg] $msg [destroy .m1] [image delete image1a] 1357} {0 {} {} {}} 1358test menu-8.3 {DestroyMenuEntry} testImageType { 1359 catch {eval image delete [image names]} 1360 catch {destroy .m1} 1361 image create test image1 1362 image create test image2 1363 menu .m1 1364 .m1 add checkbutton -image image1 -selectimage image2 1365 .m1 invoke 1 1366 list [catch {.m1 delete 1} msg] $msg [destroy .m1] [eval image delete [image names]] 1367} {0 {} {} {}} 1368test menu-8.4 {DestroyMenuEntry} { 1369 catch {destroy .m1} 1370 menu .m1 1371 .m1 add checkbutton -variable foo 1372 list [catch {.m1 delete 1} msg] $msg [destroy .m1] 1373} {0 {} {}} 1374test menu-8.5 {DestroyMenuEntry} { 1375 catch {destroy .m1} 1376 menu .m1 1377 .m1 add command -label "test" 1378 list [catch {.m1 delete 1} msg] $msg [destroy .m1] 1379} {0 {} {}} 1380test menu-8.6 {DestroyMenuEntry} { 1381 catch {destroy .m1} 1382 menu .m1 1383 .m1 add command -label "one" 1384 .m1 add command -label "two" 1385 list [catch {.m1 delete 1} msg] $msg [.m1 entrycget 1 -label] [destroy .m1] 1386} {0 {} two {}} 1387test menu-8.7 {DestroyMenuEntry} { 1388 catch {destroy .m1} 1389 catch {destroy .m2} 1390 menu .m1 1391 .m1 add command -label "one" 1392 .m1 clone .m2 tearoff 1393 list [catch {.m2 delete 0} msg] $msg [destroy .m1] 1394} {0 {} {}} 1395 1396# test menu-9 - Can only change when fonts change on system, which cannot 1397# be done from tcl. 1398 1399test menu-9.1 {ConfigureMenu} { 1400 catch {destroy .m1} 1401 menu .m1 1402 list [catch {.m1 configure -postcommand "beep"} msg] $msg [.m1 cget -postcommand] [destroy .m1] 1403} {0 {} beep {}} 1404test menu-9.2 {ConfigureMenu} { 1405 catch {destroy .m1} 1406 menu .m1 1407 .m1 add command -label "test" 1408 list [catch {.m1 configure -tearoff 0} msg] $msg [.m1 entrycget 1 -label] [destroy .m1] 1409} {0 {} test {}} 1410test menu-9.3 {ConfigureMenu} { 1411 catch {destroy .m1} 1412 menu .m1 1413 list [catch {.m1 configure -postcommand "beep"} msg] $msg [.m1 cget -postcommand] [destroy .m1] 1414} {0 {} beep {}} 1415test menu-9.4 {ConfigureMenu} { 1416 catch {destroy .m1} 1417 menu .m1 1418 .m1 add command -label "test" 1419 list [catch {.m1 configure -fg red} msg] $msg [destroy .m1] 1420} {0 {} {}} 1421test menu-9.5 {ConfigureMenu} { 1422 catch {destroy .m1} 1423 menu .m1 1424 .m1 add command -label "test" 1425 .m1 add command -label "two" 1426 list [catch {.m1 configure -fg red} msg] $msg [destroy .m1] 1427} {0 {} {}} 1428test menu-9.6 {ConfigureMenu} { 1429 catch {destroy .m1} 1430 menu .m1 1431 .m1 add command -label "test" 1432 .m1 add command -label "two" 1433 .m1 add command -label "three" 1434 list [catch {.m1 configure -fg red} msg] $msg [destroy .m1] 1435} {0 {} {}} 1436test menu-9.7 {ConfigureMenu} { 1437 catch {destroy .m1} 1438 catch {destroy .m2} 1439 menu .m1 1440 .m1 clone .m2 tearoff 1441 list [catch {.m1 configure -fg red} msg] $msg [.m2 cget -fg] [destroy .m1] 1442} {0 {} red {}} 1443test menu-9.8 {ConfigureMenu} { 1444 catch {destroy .m1} 1445 catch {destroy .m2} 1446 menu .m1 1447 .m1 clone .m2 tearoff 1448 list [catch {.m2 configure -fg red} msg] $msg [.m1 cget -fg] [destroy .m1] 1449} {0 {} red {}} 1450test menu-9.9 {ConfigureMenu} { 1451 catch {destroy .m1} 1452 menu .m1 1453 list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] 1454} {0 {} {} {}} 1455 1456test menu-10.1 {PostProcessEntry: array variable} { 1457 catch {destroy .m1} 1458 catch {unset foo} 1459 menu .m1 1460 set foo(1) on 1461 .m1 add checkbutton -variable foo(1) -onvalue on -offvalue off -label "Nonsense" 1462 list [catch {set foo(1)} msg] $msg [destroy .m1] 1463} {0 on {}} 1464test menu-10.2 {PostProcessEntry: array variable} { 1465 catch {destroy .m1} 1466 catch {unset foo} 1467 menu .m1 1468 .m1 add checkbutton -variable foo(1) -onvalue on -offvalue off -label "Nonsense" 1469 list [catch {set foo(1)} msg] $msg [destroy .m1] 1470} {0 off {}} 1471 1472test menu-11.1 {ConfigureMenuEntry} { 1473 catch {destroy .m1} 1474 catch {unset foo} 1475 menu .m1 1476 .m1 add checkbutton -variable foo -onvalue on -offvalue off -label "Nonsense" 1477 list [catch {.m1 entryconfigure 1 -variable bar} msg] $msg [.m1 entrycget 1 -variable] [destroy .m1] 1478} {0 {} bar {}} 1479test menu-11.2 {ConfigureMenuEntry} { 1480 catch {destroy .m1} 1481 menu .m1 1482 .m1 add command -label "test" 1483 list [catch {.m1 entryconfigure 1 -label ""} msg] $msg [.m1 entrycget 1 -label] [destroy .m1] 1484} {0 {} {} {}} 1485test menu-11.3 {ConfigureMenuEntry} { 1486 catch {destroy .m1} 1487 menu .m1 1488 .m1 add command 1489 list [catch {.m1 entryconfigure 1 -label "test"} cmd] $cmd [.m1 entrycget 1 -label] [destroy .m1] 1490} {0 {} test {}} 1491test menu-11.4 {ConfigureMenuEntry} { 1492 catch {destroy .m1} 1493 menu .m1 1494 .m1 add command 1495 list [catch {.m1 entryconfigure 1 -accel "S"} msg] $msg [.m1 entrycget 1 -accel] [destroy .m1] 1496} {0 {} S {}} 1497test menu-11.5 {ConfigureMenuEntry} { 1498 catch {destroy .m1} 1499 menu .m1 1500 .m1 add command 1501 list [catch {.m1 entryconfigure 1 -label "test"} msg] $msg [.m1 entrycget 1 -label] [destroy .m1] 1502} {0 {} test {}} 1503test menu-11.6 {ConfigureMenuEntry} { 1504 catch {destroy .m1} 1505 menu .m1 1506 .m1 add command 1507 list [catch {.m1 entryconfigure 1 -label "test"} msg] $msg [destroy .m1] 1508} {0 {} {}} 1509test menu-11.7 {ConfigureMenuEntry} { 1510 catch {destroy .m1} 1511 catch {destroy .m2} 1512 menu .m2 1513 menu .m1 1514 .m1 add cascade 1515 list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1 .m2] 1516} {0 {} {}} 1517test menu-11.8 {ConfigureMenuEntry} { 1518 catch {destroy .m1} 1519 menu .m1 1520 .m1 add cascade 1521 list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1] 1522} {0 {} {}} 1523test menu-11.9 {ConfigureMenuEntry} { 1524 catch {destroy .m1} 1525 menu .m1 1526 .m1 add cascade -menu .m3 1527 list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1] 1528} {0 {} {}} 1529test menu-11.10 {ConfigureMenuEntry} { 1530 catch {destroy .m1} 1531 menu .m1 1532 .m1 add cascade 1533 list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1] 1534} {0 {} {}} 1535test menu-11.11 {ConfigureMenuEntry} { 1536 catch {destroy .m1} 1537 menu .m1 1538 .m1 add cascade -menu .m2 1539 list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1] 1540} {0 {} {}} 1541test menu-11.12 {ConfigureMenuEntry} { 1542 catch {destroy .m1} 1543 catch {destroy .m2} 1544 catch {destroy .m3} 1545 catch {destroy .m4} 1546 catch {destroy .m5} 1547 menu .m1 1548 menu .m2 1549 .m2 add cascade -menu .m1 1550 menu .m3 1551 .m3 add cascade -menu .m1 1552 menu .m4 1553 .m4 add cascade -menu .m1 1554 menu .m5 1555 .m5 add cascade 1556 list [catch {.m5 entryconfigure 1 -label "test" -menu .m1} msg] $msg [destroy .m1 .m2 .m3 .m4 .m5] 1557} {0 {} {}} 1558test menu-11.13 {ConfigureMenuEntry} { 1559 catch {destroy .m1} 1560 catch {destroy .m2} 1561 catch {destroy .m3} 1562 catch {destroy .m4} 1563 menu .m1 1564 menu .m2 1565 .m2 add cascade -menu .m1 1566 menu .m3 1567 .m3 add cascade -menu .m1 1568 menu .m4 1569 .m4 add cascade -menu .m1 1570 list [catch {.m3 entryconfigure 1 -label "test" -menu .m1} msg] $msg [destroy .m1 .m2 .m3 .m4] 1571} {0 {} {}} 1572test menu-11.14 {ConfigureMenuEntry} { 1573 catch {destroy .m1} 1574 menu .m1 1575 .m1 add checkbutton 1576 list [catch {.m1 entryconfigure 1 -variable "test"} msg] $msg [.m1 entrycget 1 -variable] [destroy .m1] 1577} {0 {} test {}} 1578test menu-11.15 {ConfigureMenuEntry} { 1579 catch {destroy .m1} 1580 menu .m1 1581 list [catch {.m1 add checkbutton -label "test"} msg] $msg [.m1 entrycget 1 -variable] [destroy .m1] 1582} {0 {} test {}} 1583test menu-11.16 {ConfigureMenuEntry} { 1584 catch {destroy .m1} 1585 menu .m1 1586 list [catch {.m1 add radiobutton -label "test"} msg] $msg [destroy .m1] 1587} {0 {} {}} 1588test menu-11.17 {ConfigureMenuEntry} { 1589 catch {destroy .m1} 1590 menu .m1 1591 .m1 add checkbutton 1592 list [catch {.m1 entryconfigure 1 -onvalue "test"} msg] $msg [.m1 entrycget 1 -onvalue] [destroy .m1] 1593} {0 {} test {}} 1594test menu-11.18 {ConfigureMenuEntry} testImageType { 1595 catch {destroy .m1} 1596 catch {image delete image1} 1597 menu .m1 1598 .m1 add command 1599 image create test image1 1600 list [catch {.m1 entryconfigure 1 -image image1} msg] $msg [destroy .m1] [image delete image1] 1601} {0 {} {} {}} 1602test menu-11.19 {ConfigureMenuEntry} testImageType { 1603 catch {destroy .m1} 1604 catch {image delete image1} 1605 catch {image delete image2} 1606 image create test image1 1607 image create photo image2 -file [file join $tk_library demos images earth.gif] 1608 menu .m1 1609 .m1 add command -image image1 1610 list [catch {.m1 entryconfigure 1 -image image2} msg] $msg [destroy .m1] [image delete image1] [image delete image2] 1611} {0 {} {} {} {}} 1612test menu-11.20 {ConfigureMenuEntry} testImageType { 1613 catch {destroy .m1} 1614 catch {image delete image1} 1615 catch {image delete image2} 1616 image create photo image1 -file [file join $tk_library demos images earth.gif] 1617 image create test image2 1618 menu .m1 1619 .m1 add checkbutton -image image1 1620 list [catch {.m1 entryconfigure 1 -selectimage image2} msg] $msg [destroy .m1] [image delete image1] [image delete image2] 1621} {0 {} {} {} {}} 1622test menu-11.21 {ConfigureMenuEntry} testImageType { 1623 catch {destroy .m1} 1624 catch {image delete image1} 1625 catch {image delete image2} 1626 catch {image delete image3} 1627 image create photo image1 -file [file join $tk_library demos images earth.gif] 1628 image create test image2 1629 image create test image3 1630 menu .m1 1631 .m1 add checkbutton -image image1 -selectimage image2 1632 list [catch {.m1 entryconfigure 1 -selectimage image3} msg] $msg [destroy .m1] [image delete image1] [image delete image2] [image delete image3] 1633} {0 {} {} {} {} {}} 1634 1635test menu-12.1 {ConfigureMenuCloneEntries} { 1636 catch {destroy .m1} 1637 catch {destroy .m2} 1638 catch {destroy .m3} 1639 menu .m1 1640 .m1 clone .m2 1641 .m2 configure -tearoff 0 1642 .m1 clone .m3 1643 .m1 add command -label "test" 1644 .m1 add command -label "test2" 1645 list [list [catch {.m1 entryconfigure 1 -gork "foo"} msg] $msg] [destroy .m1] 1646} {{1 {unknown option "-gork"}} {}} 1647test menu-12.2 {ConfigureMenuCloneEntries} { 1648 catch {destroy .m1} 1649 catch {destroy .m2} 1650 catch {destroy .m3} 1651 catch {destroy .m4} 1652 menu .m1 1653 .m1 clone .m2 1654 menu .m3 1655 .m1 add cascade -menu .m3 1656 menu .m4 1657 list [catch {.m1 entryconfigure 1 -menu .m4} msg] $msg [destroy .m1] [destroy .m3] [destroy .m4] 1658} {0 {} {} {} {}} 1659test menu-12.3 {ConfigureMenuCloneEntries} { 1660 catch {destroy .m1} 1661 catch {destroy .m2} 1662 menu .m1 1663 .m1 clone .m2 1664 .m1 add cascade -label dummy 1665 list [catch {.m1 entryconfigure dummy -menu .m3} msg] $msg [destroy .m1] 1666} {0 {} {}} 1667 1668test menu-12.4 {ConfigureMenuCloneEntries} { 1669 catch {destroy .m1} 1670 catch {destroy .m2} 1671 menu .m1 1672 .m1 add cascade -label File -menu .m1.foo 1673 menu .m1.foo 1674 .m1.foo add command -label bar 1675 .m1 clone .m2 1676 list [catch {.m1 entryconfigure File -state disabled} msg1] $msg1 [destroy .m1] 1677} {0 {} {}} 1678 1679test menu-13.1 {TkGetMenuIndex} { 1680 catch {destroy .m1} 1681 menu .m1 1682 .m1 add command -label "active" 1683 .m1 add command -label "test2" 1684 .m1 add command -label "test3" 1685 .m1 activate 2 1686 list [catch {.m1 entrycget active -label} msg] $msg [destroy .m1] 1687} {0 test2 {}} 1688test menu-13.2 {TkGetMenuIndex} { 1689 catch {destroy .m1} 1690 menu .m1 1691 .m1 add command -label "last" 1692 .m1 add command -label "test2" 1693 .m1 add command -label "test3" 1694 .m1 activate 2 1695 list [catch {.m1 entrycget last -label} msg] $msg [destroy .m1] 1696} {0 test3 {}} 1697test menu-13.3 {TkGetMenuIndex} { 1698 catch {destroy .m1} 1699 menu .m1 1700 .m1 add command -label "last" 1701 .m1 add command -label "test2" 1702 .m1 add command -label "test3" 1703 .m1 activate 2 1704 list [catch {.m1 entrycget end -label} msg] $msg [destroy .m1] 1705} {0 test3 {}} 1706test menu-13.4 {TkGetMenuIndex} { 1707 catch {destroy .m1} 1708 menu .m1 1709 .m1 add command -label "test" 1710 list [catch {.m1 insert last command -label "test2"} msg] $msg [.m1 entrycget last -label] [destroy .m1] 1711} {0 {} test2 {}} 1712test menu-13.5 {TkGetMenuIndex} { 1713 catch {destroy .m1} 1714 menu .m1 1715 .m1 add command -label "test" 1716 list [catch {.m1 insert end command -label "test2"} msg] $msg [.m1 entrycget end -label] [destroy .m1] 1717} {0 {} test2 {}} 1718test menu-13.6 {TkGetMenuIndex} { 1719 catch {destroy .m1} 1720 menu .m1 1721 .m1 add command -label "active" 1722 .m1 add command -label "test2" 1723 .m1 add command -label "test3" 1724 .m1 activate 2 1725 list [catch {.m1 entrycget none -label} msg] $msg [destroy .m1] 1726} {0 {} {}} 1727#test menu-13.7 - Need to add @test here. 1728test menu-13.7 {TkGetMenuIndex} { 1729 catch {destroy .m1} 1730 menu .m1 1731 .m1 add command -label "active" 1732 .m1 add command -label "test2" 1733 .m1 add command -label "test3" 1734 list [catch {.m1 entrycget 1 -label} msg] $msg [destroy .m1] 1735} {0 active {}} 1736test menu-13.8 {TkGetMenuIndex} { 1737 catch {destroy .m1} 1738 menu .m1 1739 .m1 add command -label "active" 1740 list [catch {.m1 entrycget -1 -label} msg] $msg [destroy .m1] 1741} {1 {bad menu entry index "-1"} {}} 1742test menu-13.9 {TkGetMenuIndex} { 1743 catch {destroy .m1} 1744 menu .m1 1745 .m1 add command -label "test" 1746 .m1 add command -label "test2" 1747 list [catch {.m1 entrycget 999 -label} msg] $msg [destroy .m1] 1748} {0 test2 {}} 1749test menu-13.10 {TkGetMenuIndex} { 1750 catch {destroy .m1} 1751 menu .m1 1752 .m1 insert 999 command -label "test" 1753 list [catch {.m1 entrycget 1 -label} msg] $msg [destroy .m1] 1754} {0 test {}} 1755test menu-13.11 {TkGetMenuIndex} { 1756 catch {destroy .m1} 1757 menu .m1 1758 .m1 add command -label "1test" 1759 list [catch {.m1 entrycget 1test -label} msg] $msg [destroy .m1] 1760} {0 1test {}} 1761test menu-13.12 {TkGetMenuIndex} { 1762 catch {destroy .m1} 1763 menu .m1 1764 .m1 add command -label "test" 1765 .m1 add command -label "test2" -command "beep" 1766 .m1 add command -label "test3" 1767 list [catch {.m1 entrycget test2 -command} msg] $msg [destroy .m1] 1768} {0 beep {}} 1769 1770test menu-14.1 {MenuCmdDeletedProc} { 1771 catch {destroy .m1} 1772 menu .m1 1773 list [catch {destroy .m1} msg] $msg 1774} {0 {}} 1775test menu-14.2 {MenuCmdDeletedProc} { 1776 catch {destroy .m1} 1777 menu .m1 1778 .m1 clone .m2 1779 list [catch {destroy .m1} msg] $msg 1780} {0 {}} 1781 1782test menu-15.1 {MenuNewEntry} { 1783 catch {destroy .m1} 1784 menu .m1 1785 list [catch {.m1 add command -label "test"} msg] $msg [destroy .m1] 1786} {0 {} {}} 1787test menu-15.2 {MenuNewEntry} { 1788 catch {destroy .m1} 1789 menu .m1 1790 .m1 add command -label "test" 1791 .m1 add command -label "test3" 1792 list [catch {.m1 insert 2 command -label "test2"} msg] $msg [destroy .m1] 1793} {0 {} {}} 1794test menu-15.3 {MenuNewEntry} { 1795 catch {destroy .m1} 1796 menu .m1 1797 .m1 add command -label "test" 1798 list [catch {.m1 add command -label "test2"} msg] $msg [destroy .m1] 1799} {0 {} {}} 1800test menu-15.4 {MenuNewEntry} { 1801 catch {destroy .m1} 1802 menu .m1 1803 list [catch {.m1 add command -label "test"} msg] $msg [destroy .m1] 1804} {0 {} {}} 1805 1806test menu-16.1 {MenuAddOrInsert} { 1807 catch {destroy .m1} 1808 menu .m1 1809 list [catch {.m1 insert foo command -label "test"} msg] $msg [destroy .m1] 1810} {1 {bad menu entry index "foo"} {}} 1811test menu-16.2 {MenuAddOrInsert} { 1812 catch {destroy .m1} 1813 menu .m1 1814 .m1 add command -label "test" 1815 list [catch {.m1 insert test command -label "foo"} msg] $msg [destroy .m1] 1816} {0 {} {}} 1817test menu-16.3 {MenuAddOrInsert} { 1818 catch {destroy .m1} 1819 menu .m1 1820 list [catch {.m1 insert -1 command -label "test"} msg] $msg [destroy .m1] 1821} {1 {bad menu entry index "-1"} {}} 1822test menu-16.4 {MenuAddOrInsert} { 1823 catch {destroy .m1} 1824 menu .m1 1825 .m1 add command -label "test" 1826 .m1 insert 0 command -label "test2" 1827 list [catch {.m1 entrycget 1 -label} msg] $msg [destroy .m1] 1828} {0 test2 {}} 1829test menu-16.5 {MenuAddOrInsert} { 1830 catch {destroy .m1} 1831 menu .m1 1832 list [catch {.m1 add cascade} msg] $msg [destroy .m1] 1833} {0 {} {}} 1834test menu-16.6 {MenuAddOrInsert} { 1835 catch {destroy .m1} 1836 menu .m1 1837 list [catch {.m1 add checkbutton} msg] $msg [destroy .m1] 1838} {0 {} {}} 1839test menu-16.7 {MenuAddOrInsert} { 1840 catch {destroy .m1} 1841 menu .m1 1842 list [catch {.m1 add command} msg] $msg [destroy .m1] 1843} {0 {} {}} 1844test menu-16.8 {MenuAddOrInsert} { 1845 catch {destroy .m1} 1846 menu .m1 1847 list [catch {.m1 add radiobutton} msg] $msg [destroy .m1] 1848} {0 {} {}} 1849test menu-16.9 {MenuAddOrInsert} { 1850 catch {destroy .m1} 1851 menu .m1 1852 list [catch {.m1 add separator} msg] $msg [destroy .m1] 1853} {0 {} {}} 1854test menu-16.10 {MenuAddOrInsert} { 1855 catch {destroy .m1} 1856 menu .m1 1857 list [catch {.m1 add blork} msg] $msg [destroy .m1] 1858} {1 {bad menu entry type "blork": must be cascade, checkbutton, command, radiobutton, or separator} {}} 1859test menu-16.11 {MenuAddOrInsert} { 1860 catch {destroy .m1} 1861 menu .m1 1862 list [catch {.m1 add command} msg] $msg [destroy .m1] 1863} {0 {} {}} 1864test menu-16.12 {MenuAddOrInsert} { 1865 catch {destroy .m1} 1866 catch {destroy .m2} 1867 catch {destroy .m3} 1868 menu .m1 1869 .m1 clone .m2 1870 .m2 clone .m3 1871 list [catch {.m2 add command -label "test"} msg1] $msg1 [catch {.m1 entrycget 1 -label} msg2] $msg2 [catch {.m3 entrycget 1 -label} msg3] $msg3 [destroy .m1] 1872} {0 {} 0 test 0 test {}} 1873test menu-16.13 {MenuAddOrInsert} { 1874 catch {destroy .m1} 1875 catch {destroy .m2} 1876 catch {destroy .m3} 1877 menu .m1 1878 .m1 clone .m2 1879 .m2 clone .m3 1880 list [catch {.m3 add command -label "test"} msg1] $msg1 [catch {.m1 entrycget 1 -label} msg2] $msg2 [catch {.m2 entrycget 1 -label} msg3] $msg3 [destroy .m1] 1881} {0 {} 0 test 0 test {}} 1882test menu-16.14 {MenuAddOrInsert} { 1883 catch {destroy .m1} 1884 menu .m1 1885 list [catch {.m1 add command -blork} msg] $msg [destroy .m1] 1886} {1 {unknown option "-blork"} {}} 1887test menu-16.15 {MenuAddOrInsert} { 1888 catch {destroy .m1} 1889 catch {destroy .container} 1890 menu .m1 1891 .m1 add command -label "File" 1892 menu .container 1893 . configure -menu .container 1894 list [catch {.container add cascade -label "File" -menu .m1} msg] $msg [. configure -menu ""] [destroy .container .m1] 1895} {0 {} {} {}} 1896test menu-16.16 {MenuAddOrInsert} { 1897 catch {destroy .m1} 1898 catch {destroy .m2} 1899 menu .m1 1900 menu .m2 1901 set tearoff [tk::TearOffMenu .m2] 1902 list [catch {.m2 add cascade -menu .m1} msg] $msg [$tearoff unpost] [catch {destroy .m1} msg2] $msg2 [catch {destroy .m2} msg3] $msg3 1903} {0 {} {} 0 {} 0 {}} 1904test menu-16.17 {MenuAddOrInsert} { 1905 catch {destroy .m1} 1906 catch {destroy .container} 1907 menu .m1 1908 menu .container 1909 . configure -menu .container 1910 set tearoff [tk::TearOffMenu .container] 1911 list [catch {.container add cascade -label "File" -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1 .container] 1912} {0 {} {} {}} 1913test menu-16.18 {MenuAddOrInsert} { 1914 catch {destroy .m1} 1915 catch {destroy .container} 1916 menu .m1 1917 menu .container 1918 .container add cascade -menu .m1 1919 . configure -menu .container 1920 list [catch {.container add cascade -label "File" -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1 .container] 1921} {0 {} {} {}} 1922test menu-16.19 {MenuAddOrInsert - Insert a cascade deep into the tree} { 1923 catch {destroy .menubar} 1924 menu .menubar 1925 menu .menubar.test -tearoff 0 1926 .menubar add cascade -label Test -underline 0 -menu .menubar.test 1927 menu .menubar.test.cascade -tearoff 0 1928 .menubar.test.cascade add command -label SubItem -command "puts SubItemSelected" 1929 . configure -menu .menubar 1930 list [catch {.menubar.test add cascade -label SubMenu \ 1931 -menu .menubar.test.cascade} msg] \ 1932 [info commands .\#menubar.\#menubar\#test.\#menubar\#test\#cascade] \ 1933 [. configure -menu ""] [destroy .menubar] 1934} {0 .#menubar.#menubar#test.#menubar#test#cascade {} {}} 1935 1936test menu-17.1 {MenuVarProc} { 1937 catch {destroy .m1} 1938 catch {unset foo} 1939 menu .m1 1940 set foo "hello" 1941 list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [catch {unset foo} msg2] $msg2 [destroy .m1] 1942} {0 {} 0 {} {}} 1943# menu-17.2 - Don't know how to generate the flags in the if 1944test menu-17.2 {MenuVarProc} { 1945 catch {destroy .m1} 1946 catch {unset foo} 1947 menu .m1 1948 list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [set foo ""] [destroy .m1] 1949} {0 {} {} {}} 1950test menu-17.3 {MenuVarProc} { 1951 catch {destroy .m1} 1952 catch {unset foo} 1953 menu .m1 1954 set foo "hello" 1955 list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [set foo "hello"] [destroy .m1] [catch {unset foo} msg2] $msg2 1956} {0 {} hello {} 0 {}} 1957test menu-17.4 {MenuVarProc} { 1958 catch {destroy .m1} 1959 menu .m1 1960 set foo "goodbye" 1961 list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [set foo "hello"] [destroy .m1] [catch {unset foo} msg2] $msg2 1962} {0 {} hello {} 0 {}} 1963test menu-17.5 {MenuVarProc} { 1964 catch {destroy .m1} 1965 menu .m1 1966 set foo "hello" 1967 list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [set foo "goodbye"] [destroy .m1] [catch {unset foo} msg2] $msg2 1968} {0 {} goodbye {} 0 {}} 1969 1970test menu-18.1 {TkActivateMenuEntry} { 1971 catch {destroy .m1} 1972 menu .m1 1973 .m1 add command -label "test" 1974 list [catch {.m1 activate 1} msg] $msg [destroy .m1] 1975} {0 {} {}} 1976test menu-18.2 {TkActivateMenuEntry} { 1977 catch {destroy .m1} 1978 menu .m1 1979 .m1 add command -label "test" 1980 list [catch {.m1 activate 0} msg] $msg [destroy .m1] 1981} {0 {} {}} 1982test menu-18.3 {TkActivateMenuEntry} { 1983 catch {destroy .m1} 1984 menu .m1 1985 .m1 add command -label "test" 1986 .m1 add command -label "test2" 1987 .m1 activate 1 1988 list [catch {.m1 activate 2} msg] $msg [destroy .m1] 1989} {0 {} {}} 1990test menu-18.4 {TkActivateMenuEntry} { 1991 catch {destroy .m1} 1992 menu .m1 1993 .m1 add command -label "test" 1994 .m1 add command -label "test2" 1995 .m1 activate 1 1996 list [catch {.m1 activate 1} msg] $msg [destroy .m1] 1997} {0 {} {}} 1998 1999test menu-19.1 {TkPostCommand} {nonUnixUserInteraction } { 2000 catch {destroy .m1} 2001 menu .m1 -postcommand "set menu_test menu-19.1" 2002 .m1 add command -label "menu-19.1 - hit Escape" 2003 list [catch {.m1 post 40 40} msg] $msg [.m1 unpost] [set menu_test] [destroy .m1] 2004} {0 menu-19.1 {} menu-19.1 {}} 2005test menu-19.2 {TkPostCommand} {nonUnixUserInteraction } { 2006 catch {destroy .m1} 2007 menu .m1 2008 .m1 add command -label "menu-19.2 - hit Escape" 2009 list [catch {.m1 post 40 40} msg] $msg [.m1 unpost] [destroy .m1] 2010} {0 {} {} {}} 2011 2012test menu-20.1 {CloneMenu} { 2013 catch {destroy .m1} 2014 catch {destroy .m2} 2015 menu .m1 2016 list [catch {.m1 clone .m2} msg1] $msg1 [destroy .m1] 2017} {0 {} {}} 2018test menu-20.2 {CloneMenu} { 2019 catch {destroy .m1} 2020 catch {destroy .m2} 2021 menu .m1 2022 list [catch {.m1 clone .m2 normal} msg1] $msg1 [destroy .m1] 2023} {0 {} {}} 2024test menu-20.3 {CloneMenu} { 2025 catch {destroy .m1} 2026 catch {destroy .m2} 2027 menu .m1 2028 list [catch {.m1 clone .m2 tearoff} msg1] $msg1 [destroy .m1] 2029} {0 {} {}} 2030test menu-20.4 {CloneMenu} { 2031 catch {destroy .m1} 2032 catch {destroy .m2} 2033 menu .m1 2034 list [catch {.m1 clone .m2 menubar} msg1] $msg1 [destroy .m1] 2035} {0 {} {}} 2036test menu-20.5 {CloneMenu} { 2037 catch {destroy .m1} 2038 catch {destroy .m2} 2039 menu .m1 2040 list [catch {.m1 clone .m2 foo} msg1] $msg1 [destroy .m1] 2041} {1 {bad menu type "foo": must be normal, tearoff, or menubar} {}} 2042test menu-20.6 {CloneMenu - hooking up bookeeping ptrs} { 2043 catch {destroy .m1} 2044 catch {destroy .m2} 2045 menu .m1 2046 list [catch {.m1 clone .m2} msg] $msg [destroy .m1] 2047 } {0 {} {}} 2048 test menu-20.7 {CloneMenu - hooking up bookeeping ptrs - multiple children} { 2049 catch {destroy .m1} 2050 catch {destroy .m2} 2051 catch {destroy .m3} 2052 menu .m1 2053 .m1 clone .m2 2054 list [catch {.m1 clone .m3} msg] $msg [destroy .m1] 2055 } {0 {} {}} 2056 test menu-20.8 {CloneMenu - cascade entries} { 2057 catch {destroy .m1} 2058 catch {destroy .foo} 2059 menu .m1 2060 .m1 add cascade -menu .m2 2061 list [catch {.m1 clone .foo} msg] $msg [destroy .m1] 2062 } {0 {} {}} 2063 test menu-20.9 {CloneMenu - cascades entries} { 2064 catch {destroy .m1} 2065 catch {destroy .m2} 2066 catch {destroy .foo} 2067 menu .m1 2068 .m1 add cascade -menu .m2 2069 menu .m2 2070 list [catch {.m1 clone .foo} msg] $msg [destroy .m1 .m2] 2071 } {0 {} {}} 2072test menu-20.10 {CloneMenu - tearoff fields} { 2073 catch {destroy .m1} 2074 catch {destroy .m2} 2075 menu .m1 2076 list [catch {.m1 clone .m2 normal} msg1] $msg1 [catch {.m2 cget -tearoff} msg2] $msg2 [destroy .m1] 2077} {0 {} 0 1 {}} 2078test menu-20.11 {CloneMenu} { 2079 catch {destroy .m1} 2080 catch {destroy .m2} 2081 menu .m1 2082 menu .m2 2083 list [catch {.m1 clone .m2} msg] $msg [destroy .m1 .m2] 2084} {1 {window name "m2" already exists in parent} {}} 2085 2086test menu-21.1 {MenuDoYPosition} { 2087 catch {destroy .m1} 2088 menu .m1 2089 list [catch {.m1 yposition glorp} msg] $msg [destroy .m1] 2090} {1 {bad menu entry index "glorp"} {}} 2091test menu-21.2 {MenuDoYPosition} { 2092 catch {destroy .m1} 2093 menu .m1 2094 .m1 add command -label "Test" 2095 list [catch {.m1 yposition 1}] [destroy .m1] 2096} {0 {}} 2097 2098test menu-22.1 {GetIndexFromCoords} { 2099 catch {destroy .m1} 2100 menu .m1 2101 .m1 add command -label "test" 2102 .m1 configure -tearoff 0 2103 list [catch {.m1 index @5} msg] $msg [destroy .m1] 2104} {0 0 {}} 2105test menu-22.2 {GetIndexFromCoords} { 2106 catch {destroy .m1} 2107 menu .m1 2108 .m1 add command -label "test" 2109 .m1 configure -tearoff 0 2110 list [catch {.m1 index @5,5} msg] $msg [destroy .m1] 2111} {0 0 {}} 2112 2113test menu-23.1 {RecursivelyDeleteMenu} { 2114 catch {destroy .m1} 2115 menu .m1 2116 . configure -menu .m1 2117 list [catch {. configure -menu ""} msg] $msg [destroy .m1] 2118} {0 {} {}} 2119test menu-23.2 {RecursivelyDeleteMenu} { 2120 catch {destroy .m1} 2121 catch {destroy .m2} 2122 menu .m2 2123 .m2 add command -label "test2" 2124 menu .m1 2125 .m1 add cascade -label "test1" -menu .m2 2126 . configure -menu .m1 2127 list [catch {. configure -menu ""} msg] $msg [destroy .m1 .m2] 2128} {0 {} {}} 2129 2130test menu-24.1 {TkNewMenuName} { 2131 catch {destroy .m1} 2132 menu .m1 2133 list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] 2134} {0 {} {} {}} 2135test menu-24.2 {TkNewMenuName} { 2136 catch {destroy .m1} 2137 catch {destroy .m1\#0} 2138 menu .m1 2139 menu .m1\#0 2140 list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] 2141} {0 {} {} {}} 2142test menu-24.3 {TkNewMenuName} { 2143 catch {destroy .#m} 2144 menu .#m 2145 rename .#m hideme 2146 list [catch {. configure -menu [menu .m]} $msg] [. configure -menu ""] [destroy .#m] [destroy .m] [destroy hideme] 2147} {0 {} {} {} {}} 2148 2149test menu-25.1 {TkSetWindowMenuBar} { 2150 . configure -menu "" 2151 list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] 2152} {0 {} {}} 2153test menu-25.2 {TkSetWindowMenuBar} { 2154 . configure -menu "" 2155 list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] 2156} {0 {} {}} 2157test menu-25.3 {TkSetWindowMenuBar} { 2158 . configure -menu "" 2159 catch {destroy .m1} 2160 menu .m1 2161 list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] 2162} {0 {} {} {}} 2163test menu-25.4 {TkSetWindowMenuBar} { 2164 catch {destroy .m1} 2165 catch {destroy .m2} 2166 . configure -menu "" 2167 menu .m1 2168 . configure -menu .m1 2169 menu .m2 2170 list [catch {. configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .m1 .m2] 2171} {0 {} {} {}} 2172test menu-25.5 {TkSetWindowMenuBar} { 2173 catch {destroy .m1} 2174 catch {destroy .m2} 2175 catch {destroy .m3} 2176 . configure -menu "" 2177 menu .m1 2178 . configure -menu .m1 2179 .m1 clone .m2 2180 menu .m3 2181 list [catch {. configure -menu .m3} msg] $msg [. configure -menu ""] [destroy .m1 .m3] 2182} {0 {} {} {}} 2183test menu-25.6 {TkSetWindowMenuBar} { 2184 catch {destroy .m1} 2185 catch {destroy .m2} 2186 catch {destroy .m3} 2187 . configure -menu "" 2188 menu .m1 2189 .m1 clone .m2 2190 . configure -menu .m2 2191 menu .m3 2192 list [catch {. configure -menu .m3} msg] $msg [. configure -menu ""] [destroy .m1 .m3] 2193} {0 {} {} {}} 2194test menu-25.7 {TkSetWindowMenuBar} { 2195 catch {destroy .m1} 2196 catch {destroy .m2} 2197 . configure -menu "" 2198 menu .m1 2199 menu .m2 2200 . configure -menu .m1 2201 toplevel .t2 2202 .t2 configure -menu .m1 2203 list [catch {.t2 configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .m1 .m2] 2204} {0 {} {} {}} 2205test menu-25.8 {TkSetWindowMenuBar} { 2206 catch {destroy .m1} 2207 catch {destroy .m2} 2208 catch {destroy .t2} 2209 . configure -menu "" 2210 menu .m1 2211 menu .m2 2212 . configure -menu .m1 2213 toplevel .t2 2214 wm geometry .t2 +0+0 2215 .t2 configure -menu .m1 2216 list [catch {. configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .m1 .m2] 2217} {0 {} {} {}} 2218test menu-25.9 {TkSetWindowMenuBar} { 2219 catch {destroy .m1} 2220 catch {destroy .m2} 2221 catch {destroy .t2} 2222 catch {destroy .t3} 2223 . configure -menu "" 2224 menu .m1 2225 menu .m2 2226 . configure -menu .m1 2227 toplevel .t2 -menu .m1 2228 wm geometry .t2 +0+0 2229 toplevel .t3 -menu .m1 2230 wm geometry .t3 +0+0 2231 list [catch {.t3 configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .t3 .m1 .m2] 2232} {0 {} {} {}} 2233test menu-25.10 {TkSetWindowMenuBar} { 2234 catch {destroy .m1} 2235 catch {destroy .m2} 2236 catch {destroy .t2} 2237 catch {destroy .t3} 2238 . configure -menu "" 2239 menu .m1 2240 menu .m2 2241 . configure -menu .m1 2242 toplevel .t2 -menu .m1 2243 wm geometry .t2 +0+0 2244 toplevel .t3 -menu .m1 2245 wm geometry .t3 +0+0 2246 list [catch {.t2 configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .t3 .m1 .m2] 2247} {0 {} {} {}} 2248test menu-25.11 {TkSetWindowMenuBar} { 2249 catch {destroy .m1} 2250 catch {destroy .m2} 2251 catch {destroy .t2} 2252 catch {destroy .t3} 2253 . configure -menu "" 2254 menu .m1 2255 menu .m2 2256 . configure -menu .m1 2257 toplevel .t2 -menu .m1 2258 wm geometry .t2 +0+0 2259 toplevel .t3 -menu .m1 2260 wm geometry .t3 +0+0 2261 list [catch {. configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .t3 .m1 .m2] 2262} {0 {} {} {}} 2263test menu-25.12 {TkSetWindowMenuBar} { 2264 catch {destroy .m1} 2265 . configure -menu "" 2266 menu .m1 2267 list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] 2268} {0 {} {} {}} 2269test menu-25.13 {TkSetWindowMenuBar} { 2270 . configure -menu "" 2271 list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] 2272} {0 {} {}} 2273test menu-25.14 {TkSetWindowMenuBar} { 2274 catch {destroy .m1} 2275 . configure -menu "" 2276 menu .m1 2277 list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] 2278} {0 {} {} {}} 2279test menu-25.15 {TkSetWindowMenuBar} { 2280 . configure -menu "" 2281 list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] 2282} {0 {} {}} 2283test menu-25.16 {TkSetWindowMenuBar} { 2284 catch {destroy .m1} 2285 . configure -menu "" 2286 menu .m1 2287 . configure -menu .m1 2288 list [catch {toplevel .t2 -menu m1} msg] $msg [. configure -menu ""] [destroy .t2 .m1] 2289} {0 .t2 {} {}} 2290 2291test menu-26.1 {DestroyMenuHashTable} { 2292 catch {interp destroy testinterp} 2293 interp create testinterp 2294 load {} Tk testinterp 2295 interp eval testinterp {menu .m1} 2296 list [catch {interp delete testinterp} msg] $msg 2297} {0 {}} 2298 2299test menu-27.1 {GetMenuHashTable} { 2300 catch {interp destroy testinterp} 2301 interp create testinterp 2302 load {} Tk testinterp 2303 list [catch {interp eval testinterp {menu .m1}} msg] $msg [interp delete testinterp] 2304} {0 .m1 {}} 2305 2306test menu-28.1 {TkCreateMenuReferences - not there before} { 2307 catch {destroy .m1} 2308 list [catch {menu .m1} msg] $msg [destroy .m1] 2309} {0 .m1 {}} 2310test menu-28.2 {TkCreateMenuReferences - there already} { 2311 catch {destroy .m1} 2312 catch {destroy .m2} 2313 menu .m1 2314 .m1 add cascade -menu .m2 2315 list [catch {menu .m2} msg] $msg [destroy .m1 .m2] 2316} {0 .m2 {}} 2317 2318test menu-29.1 {TkFindMenuReferences - not there} { 2319 catch {destroy .m1} 2320 . configure -menu "" 2321 menu .m1 2322 .m1 add cascade -menu .m2 2323 list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] 2324} {0 {} {} {}} 2325test menu-30.1 {TkFindMenuReferences - there already} { 2326 catch {destroy .m1} 2327 catch {destroy .m2} 2328 . configure -menu "" 2329 menu .m1 2330 menu .m2 2331 .m1 add cascade -menu .m2 2332 list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1 .m2] 2333} {0 {} {} {}} 2334 2335test menu-31.1 {TkFreeMenuReferences - menuPtr} { 2336 catch {destroy .m1} 2337 menu .m1 2338 list [catch {destroy .m1} msg] $msg 2339} {0 {}} 2340test menu-31.2 {TkFreeMenuReferences - cascadePtr} { 2341 catch {destroy .m1} 2342 . configure -menu "" 2343 menu .m1 2344 .m1 add cascade -menu .m2 2345 list [catch {.m1 entryconfigure 1 -menu .m3} msg] $msg [destroy .m1] 2346} {0 {} {}} 2347test menu-31.3 {TkFreeMenuReferences - topLevelListPtr} { 2348 . configure -menu .m1 2349 list [catch {. configure -menu ""} msg] $msg 2350} {0 {}} 2351test menu-31.4 {TkFreeMenuReferences - not empty} { 2352 catch {destroy .m1} 2353 catch {destroy .m2} 2354 menu .m1 2355 .m1 add cascade -menu .m3 2356 menu .m2 2357 .m2 add cascade -menu .m3 2358 list [catch {.m2 entryconfigure 1 -menu ".foo"} msg] $msg [destroy .m1 .m2] 2359} {0 {} {}} 2360 2361test menu-32.1 {DeleteMenuCloneEntries} { 2362 catch {destroy .m1} 2363 catch {destroy .m2} 2364 menu .m1 2365 .m1 add command -label foo 2366 .m1 clone .m2 2367 list [catch {.m1 delete 1} msg] $msg [destroy .m1] 2368} {0 {} {}} 2369test menu-32.2 {DeleteMenuCloneEntries} { 2370 catch {destroy .m1} 2371 catch {destroy .m2} 2372 menu .m1 2373 .m1 add command -label one 2374 .m1 add command -label two 2375 .m1 add command -label three 2376 .m1 add command -label four 2377 .m1 clone .m2 2378 list [catch {.m1 delete 2 3} msg] $msg [destroy .m1] 2379} {0 {} {}} 2380test menu-32.3 {DeleteMenuCloneEntries} { 2381 catch {destroy .m1} 2382 catch {destroy .m2} 2383 menu .m1 -tearoff 0 2384 .m1 add command -label one 2385 .m1 add command -label two 2386 .m1 add command -label three 2387 .m1 add command -label four 2388 .m1 clone .m2 2389 .m2 configure -tearoff 1 2390 list [catch {.m1 delete 1 2} msg] $msg [destroy .m1] 2391} {0 {} {}} 2392test menu-32.4 {DeleteMenuCloneEntries} { 2393 catch {destroy .m1} 2394 catch {destroy .m2} 2395 menu .m1 2396 .m1 add command -label one 2397 .m1 add command -label two 2398 .m1 add command -label three 2399 .m1 add command -label four 2400 .m1 clone .m2 2401 .m2 configure -tearoff 0 2402 list [catch {.m1 delete 2 3} msg] $msg [destroy .m1] 2403} {0 {} {}} 2404test menu-32.5 {DeleteMenuCloneEntries} { 2405 catch {destroy .m1} 2406 catch {destroy .m2} 2407 menu .m1 2408 .m1 add command -label one 2409 .m1 add command -label two 2410 .m1 clone .m2 2411 .m1 activate one 2412 list [catch {.m1 delete one} msg] $msg [destroy .m1] 2413} {0 {} {}} 2414test menu-32.6 {DeleteMenuCloneEntries - reentrancy - crashes tk8.0} { 2415 catch {destroy .m1} 2416 menu .m1 2417 .m1 add command -label test -command ".m1 delete test ; .m1 add command -label test -command \".m1 delete test\"; .m1 delete test" 2418 list [catch {.m1 invoke test} msg] $msg [destroy .m1] 2419} {0 {} {}} 2420test menu-32.7 {DeleteMenuCloneEntries - one entry} { 2421 catch {destroy .m1} 2422 menu .m1 -tearoff 0 2423 .m1 add command -label Hello 2424 list [catch {.m1 delete Hello} msg] $msg [destroy .m1] 2425} {0 {} {}} 2426test menu-32.8 {Ensure all menu clone commands are deleted} { 2427 # SF bug #465324 2428 catch {destroy .menubar} 2429 catch {destroy .menubar.test} 2430 menu .menubar 2431 . configure -menu .menubar 2432 menu .menubar.test 2433 .menubar.test add command -label "hi" 2434 for {set i 0} {$i < 10} {incr i} { 2435 .menubar add cascade -menu .menubar.test -label "Test" 2436 .menubar delete Test 2437 } 2438 2439 info commands .#menubar*test* 2440} {} 2441test menu-32.9 {Ensure deleting of clones doesn't corrupt menu refs} { 2442 catch {destroy .menubar} 2443 catch {destroy .menubar.test} 2444 2445 menu .menubar 2446 . configure -menu .menubar 2447 menu .menubar.test 2448 .menubar add cascade -menu .menubar.test -label "Test" 2449 menu .menubar.cascade 2450 2451 .menubar.test add cascade -menu .menubar.cascade -label "Cascade" 2452 set res {} 2453 lappend res [.menubar.test entrycget 1 -menu] 2454 lappend res [.#menubar.#menubar#test entrycget 1 -menu] 2455 destroy .menubar.test 2456 menu .menubar.test 2457 .menubar.test add cascade -menu .menubar.cascade -label "Cascade" 2458 lappend res [.menubar.test entrycget 1 -menu] 2459 lappend res [.#menubar.#menubar#test entrycget 1 -menu] 2460 set res 2461} {.menubar.cascade .#menubar.#menubar#test.#menubar#cascade .menubar.cascade .#menubar.#menubar#test.#menubar#cascade} 2462 2463set l [interp hidden] 2464deleteWindows 2465 2466test menu-33.1 {menu vs command hiding} { 2467 catch {destroy .m} 2468 menu .m 2469 interp hide {} .m 2470 destroy .m 2471 list [winfo children .] [interp hidden] 2472} [list {} $l] 2473 2474# menu-34 MenuInit only called at boot time 2475 2476# creating menus on two different screens then deleting the 2477# menu from the first screen crashes Tk8.3.1 2478# 2479test menu-35.1 {menus on multiple screens - crashes tk8.3.1, Bug 5454} \ 2480 {altDisplay} { 2481 toplevel .one 2482 menu .one.m 2483 toplevel .two -screen $::env(TK_ALT_DISPLAY) 2484 menu .two.m 2485 destroy .one 2486 destroy .two 2487} {} 2488 2489test menu-36.1 {menu -underline string overruns Bug 1599877} {} { 2490 # ensure that -underline does not do string overruns [Bug 1599877] 2491 catch {destroy .m} 2492 menu .m 2493 .m add command -label "File" -underline [expr {1<<30}] 2494 . configure -menu .m 2495 update 2496 tk::TraverseToMenu . "e" 2497} {} 2498 2499# cleanup 2500deleteWindows 2501::tcltest::cleanupTests 2502return 2503