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