#
# RCS: @(#) $Id$
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-if {[lsearch [image types] test] < 0} {
- puts "This application hasn't been compiled with the \"test\" image"
- puts "type, so I can't run this test. Are you sure you're using"
- puts "tktest instead of wish?"
- ::tcltest::cleanupTests
- return
-}
-
-# Some tests require user interaction on non-unix platform
-set ::tcltest::testConfig(nonUnixUserInteraction) \
- [expr {$::tcltest::testConfig(userInteraction) || \
- $::tcltest::testConfig(unixOnly)}]
-
-proc deleteWindows {} {
- foreach i [winfo children .] {
- catch [destroy $i]
- }
-}
-
-deleteWindows
-wm geometry . {}
-raise .
+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]
+tcltest::loadTestedCommands
test menu-1.1 {Tk_MenuCmd procedure} {
list [catch menu msg] $msg
menu .m1
.m1 add command -label "test"
list [catch {llength [.m1 entryconfigure 1]} msg] $msg [destroy .m1]
-} {0 14 {}}
+} {0 15 {}}
test menu-3.37 {MenuWidgetCmd procedure, "entryconfigure" option} {
catch {destroy .m1}
menu .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} {}}
+test menu-3.68 {MenuWidgetCmd procedure, fix for bug#508988} {
+ set t .t
+ set m1 .t.m1
+ set c1 .t.c1
+ set c2 .t.c2
+ toplevel .t
+ menu $m1 -tearoff 1
+ menu $c1 -tearoff 1
+ $c1 add command -label c1
+ menu $c2 -tearoff 1
+ $c2 add command -label c2
+ $m1 add cascade -label c1 -menu $c1
+ $t configure -menu $m1
+ $m1 entryconfigure 1 -menu $c2 -label c2
+ $t configure -menu ""
+ set l [list [winfo exists $c1] [winfo exists $c2]]
+ destroy $t;
+ set l;
+} {1 1}
test menu-4.1 {TkInvokeMenu: disabled} {
catch {destroy .m1}
test menu-5.7 {DestroyMenuInstance - basic clones} {
catch {destroy .m1}
menu .m1
- set tearoff [tkTearOffMenu .m1]
+ set tearoff [tk::TearOffMenu .m1]
list [catch {destroy $tearoff} msg] $msg [destroy .m1]
} {0 {} {}}
test menu-5.8 {DestroyMenuInstance - multiple clones} {
catch {destroy .m1}
menu .m1
- set tearoff1 [tkTearOffMenu .m1]
- set tearoff2 [tkTearOffMenu .m1]
+ set tearoff1 [tk::TearOffMenu .m1]
+ set tearoff2 [tk::TearOffMenu .m1]
list [catch {destroy $tearoff1} msg] $msg [destroy .m1]
} {0 {} {}}
test menu-5.9 {DestroyMenuInstace - master menu} {
catch {destroy .m1}
menu .m1
- tkTearOffMenu .m1
+ tk::TearOffMenu .m1
list [catch {destroy .m1} msg] $msg
} {0 {}}
test menu-5.10 {DestroyMenuInstance - freeing entries} {
menu .m1
menu .m2
.m1 add cascade -menu .m2
- set tearoff [tkTearOffMenu .m1 40 40]
+ set tearoff [tk::TearOffMenu .m1 40 40]
list [destroy .m2] [destroy .m1]
} {{} {}}
.m1 add command -image image1a
list [catch {.m1 delete 1} msg] $msg [destroy .m1] [image delete image1a]
} {0 {} {} {}}
-test menu-8.3 {DestroyMenuEntry} {
+test menu-8.3 {DestroyMenuEntry} testImageType {
catch {eval image delete [image names]}
catch {destroy .m1}
image create test image1
.m1 add checkbutton
list [catch {.m1 entryconfigure 1 -onvalue "test"} msg] $msg [.m1 entrycget 1 -onvalue] [destroy .m1]
} {0 {} test {}}
-test menu-11.18 {ConfigureMenuEntry} {
+test menu-11.18 {ConfigureMenuEntry} testImageType {
catch {destroy .m1}
catch {image delete image1}
menu .m1
image create test image1
list [catch {.m1 entryconfigure 1 -image image1} msg] $msg [destroy .m1] [image delete image1]
} {0 {} {} {}}
-test menu-11.19 {ConfigureMenuEntry} {
+test menu-11.19 {ConfigureMenuEntry} testImageType {
catch {destroy .m1}
catch {image delete image1}
catch {image delete image2}
.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} {
+test menu-11.20 {ConfigureMenuEntry} testImageType {
catch {destroy .m1}
catch {image delete image1}
catch {image delete image2}
.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} {
+test menu-11.21 {ConfigureMenuEntry} testImageType {
catch {destroy .m1}
catch {image delete image1}
catch {image delete image2}
catch {destroy .m2}
menu .m1
menu .m2
- set tearoff [tkTearOffMenu .m2]
+ set tearoff [tk::TearOffMenu .m2]
list [catch {.m2 add cascade -menu .m1} msg] $msg [$tearoff unpost] [catch {destroy .m1} msg2] $msg2 [catch {destroy .m2} msg3] $msg3
} {0 {} {} 0 {} 0 {}}
test menu-16.17 {MenuAddOrInsert} {
menu .m1
menu .container
. configure -menu .container
- set tearoff [tkTearOffMenu .container]
+ set tearoff [tk::TearOffMenu .container]
list [catch {.container add cascade -label "File" -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1 .container]
} {0 {} {} {}}
test menu-16.18 {MenuAddOrInsert} {
test menu-27.1 {GetMenuHashTable} {
catch {interp destroy testinterp}
interp create testinterp
- load {} tk testinterp
+ load {} Tk testinterp
list [catch {interp eval testinterp {menu .m1}} msg] $msg [interp delete testinterp]
} {0 .m1 {}}
.m1 add command -label Hello
list [catch {.m1 delete Hello} msg] $msg [destroy .m1]
} {0 {} {}}
+test menu-32.8 {Ensure all menu clone commands are deleted} {knownBug} {
+ # SF bug #465324
+ catch {destroy .menubar}
+ catch {destroy .menubar.test}
+ menu .menubar
+ . configure -menu .menubar
+ menu .menubar.test
+ .menubar.test add command -label "hi"
+ for {set i 0} {$i < 10} {incr i} {
+ .menubar add cascade -menu .menubar.test -label "Test"
+ .menubar delete Test
+ }
+
+ info commands .#menubar*test*
+} {}
+test menu-32.9 {Ensure deleting of clones doesn't corrupt menu refs} {
+ catch {destroy .menubar}
+ catch {destroy .menubar.test}
+
+ menu .menubar
+ . configure -menu .menubar
+ menu .menubar.test
+ .menubar add cascade -menu .menubar.test -label "Test"
+ menu .menubar.cascade
+
+ .menubar.test add cascade -menu .menubar.cascade -label "Cascade"
+ set res {}
+ lappend res [.menubar.test entrycget 1 -menu]
+ lappend res [.#menubar.#menubar#test entrycget 1 -menu]
+ destroy .menubar.test
+ menu .menubar.test
+ .menubar.test add cascade -menu .menubar.cascade -label "Cascade"
+ lappend res [.menubar.test entrycget 1 -menu]
+ lappend res [.#menubar.#menubar#test entrycget 1 -menu]
+ set res
+} {.menubar.cascade .#menubar.#menubar#test.#menubar#cascade .menubar.cascade .#menubar.#menubar#test.#menubar#cascade}
set l [interp hidden]
-eval destroy [winfo children .]
+deleteWindows
test menu-33.1 {menu vs command hiding} {
catch {destroy .m}
# creating menus on two different screens then deleting the
# menu from the first screen crashes Tk8.3.1
#
-test menu-35.1 {menus on multiple screens - crashes tk8.3.1, Bug 5454} {
- if {[info exists ::env(TK_ALT_DISPLAY)]} {
- toplevel .one
- menu .one.m
- toplevel .two -screen $::env(TK_ALT_DISPLAY)
- menu .two.m
- destroy .one
- destroy .two
- }
+test menu-35.1 {menus on multiple screens - crashes tk8.3.1, Bug 5454} \
+ {altDisplay} {
+ toplevel .one
+ menu .one.m
+ toplevel .two -screen $::env(TK_ALT_DISPLAY)
+ menu .two.m
+ destroy .one
+ destroy .two
} {}
# cleanup
deleteWindows
::tcltest::cleanupTests
return
-
OSDN Git Service
