diff options
Diffstat (limited to 'tests/menu.test')
| -rw-r--r-- | tests/menu.test | 115 |
1 files changed, 91 insertions, 24 deletions
diff --git a/tests/menu.test b/tests/menu.test index 98978c5..3cb47c3 100644 --- a/tests/menu.test +++ b/tests/menu.test @@ -6,12 +6,13 @@ # All rights reserved. package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] +eval tcltest::configure $argv tcltest::loadTestedCommands +# find the earth.gif file for use in these tests +set earthPhotoFile [file join [file dirname [info script]] earth.gif] +testConstraint hasEarthPhoto [file exists $earthPhotoFile] + test menu-1.1 {Tk_MenuCmd procedure} { list [catch menu msg] $msg } {1 {wrong # args: should be "menu pathName ?options?"}} @@ -196,7 +197,9 @@ menu .m2 .m1 add separator .m1 add checkbutton -label "checkbutton" -variable check -onvalue on -offvalue off .m1 add radiobutton -label "radiobutton" -variable radio -image create photo image1 -file [file join $tk_library demos images earth.gif] +if {[testConstraint hasEarthPhoto]} { + image create photo image1 -file $earthPhotoFile +} foreach configTest { {-activebackground @@ -489,7 +492,9 @@ foreach configTest { set options [lindex $attempt 1] foreach item {0 1 2 3 4 5} { catch {unset msg} - test menu-2.$i [list entry configuration options $name $item $value [.m1 type $item]] { + # OK, it's an overeager constraint, but it should also + # normally hold anyway + test menu-2.$i [list entry configuration options $name $item $value [.m1 type $item]] hasEarthPhoto { set result [catch {.m1 entryconfigure $item $name $value} msg] if {$result == 1} { set msg @@ -502,7 +507,9 @@ foreach configTest { } } -image delete image1 +if {[testConstraint hasEarthPhoto]} { + image delete image1 +} destroy .m1 destroy .m2 @@ -672,6 +679,17 @@ test menu-3.29 {MenuWidgetCmd procedure, "delete" option} { .m1 activate 3 list [catch {.m1 delete 1} msg] $msg [destroy .m1] } {0 {} {}} +test menu-3.29+1 {MenuWidgetCmd, "delete", Bug 220950} -setup { + destroy .m1 +} -body { + menu .m1 + .m1 add command -label "bogus" + .m1 add command -label "ok" + .m1 delete 10 20 + .m1 entrycget last -label +} -cleanup { + destroy .m1 +} -result ok test menu-3.30 {MenuWidgetCmd procedure, "entrycget" option} { catch {destroy .m1} menu .m1 @@ -888,7 +906,7 @@ test menu-3.67 {MenuWidgetCmd procedure, bad option} { catch {destroy .m1} menu .m1 list [catch {.m1 foo} msg] $msg [destroy .m1] -} {1 {bad option "foo": must be activate, add, cget, clone, configure, delete, entrycget, entryconfigure, index, insert, invoke, post, postcascade, type, unpost, or yposition} {}} +} {1 {bad option "foo": must be activate, add, cget, clone, configure, delete, entrycget, entryconfigure, index, insert, invoke, post, postcascade, type, unpost, xposition, or yposition} {}} test menu-3.68 {MenuWidgetCmd procedure, fix for bug#508988} { set t .t set m1 .t.m1 @@ -908,6 +926,23 @@ test menu-3.68 {MenuWidgetCmd procedure, fix for bug#508988} { destroy $t; set l; } {1 1} +test menu-3.69 {MenuWidgetCmd procedure, "xposition" option} -setup { + catch {destroy .m1} + menu .m1 +} -body { + .m1 xposition +} -cleanup { + destroy .m1 +} -returnCodes error -result {wrong # args: should be ".m1 xposition index"} +test menu-3.70 {MenuWidgetCmd procedure, "xposition" option} -setup { + catch {destroy .m1} + menu .m1 +} -body { + .m1 xposition 1 + subst {} ;# just checking that the xposition does not produce an error... +} -cleanup { + destroy .m1 +} -result {} test menu-4.1 {TkInvokeMenu: disabled} { catch {destroy .m1} @@ -1345,10 +1380,10 @@ test menu-8.1 {DestroyMenuEntry} { .m1 add cascade -menu .m2 list [catch {.m1 delete 1} msg] $msg [destroy .m1 .m2] } {0 {} {}} -test menu-8.2 {DestroyMenuEntry} { +test menu-8.2 {DestroyMenuEntry} hasEarthPhoto { catch {image delete image1a} catch {destroy .m1} - image create photo image1a -file [file join $tk_library demos images earth.gif] + image create photo image1a -file $earthPhotoFile menu .m1 .m1 add command -image image1a list [catch {.m1 delete 1} msg] $msg [destroy .m1] [image delete image1a] @@ -1597,32 +1632,32 @@ test menu-11.18 {ConfigureMenuEntry} testImageType { image create test image1 list [catch {.m1 entryconfigure 1 -image image1} msg] $msg [destroy .m1] [image delete image1] } {0 {} {} {}} -test menu-11.19 {ConfigureMenuEntry} testImageType { +test menu-11.19 {ConfigureMenuEntry} {testImageType hasEarthPhoto} { catch {destroy .m1} catch {image delete image1} catch {image delete image2} image create test image1 - image create photo image2 -file [file join $tk_library demos images earth.gif] + image create photo image2 -file $earthPhotoFile menu .m1 .m1 add command -image image1 list [catch {.m1 entryconfigure 1 -image image2} msg] $msg [destroy .m1] [image delete image1] [image delete image2] } {0 {} {} {} {}} -test menu-11.20 {ConfigureMenuEntry} testImageType { +test menu-11.20 {ConfigureMenuEntry} {testImageType hasEarthPhoto} { catch {destroy .m1} catch {image delete image1} catch {image delete image2} - image create photo image1 -file [file join $tk_library demos images earth.gif] + image create photo image1 -file $earthPhotoFile image create test image2 menu .m1 .m1 add checkbutton -image image1 list [catch {.m1 entryconfigure 1 -selectimage image2} msg] $msg [destroy .m1] [image delete image1] [image delete image2] } {0 {} {} {} {}} -test menu-11.21 {ConfigureMenuEntry} testImageType { +test menu-11.21 {ConfigureMenuEntry} {testImageType hasEarthPhoto} { catch {destroy .m1} catch {image delete image1} catch {image delete image2} catch {image delete image3} - image create photo image1 -file [file join $tk_library demos images earth.gif] + image create photo image1 -file $earthPhotoFile image create test image2 image create test image3 menu .m1 @@ -2042,23 +2077,23 @@ test menu-20.6 {CloneMenu - hooking up bookeeping ptrs} { catch {destroy .m2} menu .m1 list [catch {.m1 clone .m2} msg] $msg [destroy .m1] - } {0 {} {}} - test menu-20.7 {CloneMenu - hooking up bookeeping ptrs - multiple children} { +} {0 {} {}} +test menu-20.7 {CloneMenu - hooking up bookeeping ptrs - multiple children} { catch {destroy .m1} catch {destroy .m2} catch {destroy .m3} menu .m1 .m1 clone .m2 list [catch {.m1 clone .m3} msg] $msg [destroy .m1] - } {0 {} {}} - test menu-20.8 {CloneMenu - cascade entries} { +} {0 {} {}} +test menu-20.8 {CloneMenu - cascade entries} { catch {destroy .m1} catch {destroy .foo} menu .m1 .m1 add cascade -menu .m2 list [catch {.m1 clone .foo} msg] $msg [destroy .m1] - } {0 {} {}} - test menu-20.9 {CloneMenu - cascades entries} { +} {0 {} {}} +test menu-20.9 {CloneMenu - cascades entries} { catch {destroy .m1} catch {destroy .m2} catch {destroy .foo} @@ -2066,7 +2101,7 @@ test menu-20.6 {CloneMenu - hooking up bookeeping ptrs} { .m1 add cascade -menu .m2 menu .m2 list [catch {.m1 clone .foo} msg] $msg [destroy .m1 .m2] - } {0 {} {}} +} {0 {} {}} test menu-20.10 {CloneMenu - tearoff fields} { catch {destroy .m1} catch {destroy .m2} @@ -2107,6 +2142,38 @@ test menu-22.2 {GetIndexFromCoords} { .m1 configure -tearoff 0 list [catch {.m1 index @5,5} msg] $msg [destroy .m1] } {0 0 {}} +test menu-22.3 {GetIndexFromCoords: mapped window, y only} unix { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + .m1 configure -tearoff 0 + tk_popup .m1 0 0 + tkwait visibility .m1 + list [catch {.m1 index @5} msg] $msg [destroy .m1] +} {0 0 {}} +test menu-22.4 {GetIndexFromCoords: mapped window x,y} unix { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + .m1 configure -tearoff 0 + tk_popup .m1 0 0 + tkwait visibility .m1 + update + set x [expr {[winfo width .m1] - [.m1 cget -borderwidth] - 1}] + list [catch {.m1 index @$x,5} msg] $msg [destroy .m1] +} {0 0 {}} +test menu-22.5 {GetIndexFromCoords: mapped wide window} unix { + catch {destroy .m1} + menu .m1 + .m1 add command -label "test" + .m1 configure -tearoff 0 + tk_popup .m1 0 0 + tkwait visibility .m1 + wm geometry .m1 200x100 + update + set x [expr {[winfo width .m1] - [.m1 cget -borderwidth] - 1}] + list [catch {.m1 index @$x,5} msg] $msg [destroy .m1] +} {0 0 {}} test menu-23.1 {RecursivelyDeleteMenu} { catch {destroy .m1} @@ -2496,5 +2563,5 @@ test menu-36.1 {menu -underline string overruns Bug 1599877} {} { # cleanup deleteWindows -::tcltest::cleanupTests +cleanupTests return |