archie/tk4.2/tests/menu.test
2024-05-27 16:40:40 +02:00

188 lines
5.2 KiB
Plaintext

# This file is a Tcl script to test menus in Tk. It is
# organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1995 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# SCCS: @(#) menu.test 1.9 96/03/26 16:09:06
# XXX This test file is woefully incomplete right now.
if {[info procs test] != "test"} {
source defs
}
foreach i [winfo children .] {
destroy $i
}
wm geometry . {}
raise .
test menu-1.1 {MenuWidgetCmd procedure, "add" option} {
catch {destroy .m}
menu .m
list [catch {.m add} msg] $msg
} {1 {wrong # args: should be ".m add type ?options?"}}
test menu-1.2 {MenuWidgetCmd procedure, "add" option} {
catch {destroy .m}
menu .m
list [catch {.m add gorp} msg] $msg
} {1 {bad menu entry type "gorp": must be cascade, checkbutton, command, radiobutton, or separator}}
test menu-1.3 {MenuWidgetCmd procedure, "add" option} {
catch {destroy .m}
menu .m
.m add command -label first
.m entrycget 1 -label
} {first}
test menu-2.1 {MenuWidgetCmd procedure, "insert" option} {
catch {destroy .m}
menu .m
list [catch {.m insert 1} msg] $msg
} {1 {wrong # args: should be ".m insert index type ?options?"}}
test menu-2.2 {MenuWidgetCmd procedure, "insert" option} {
catch {destroy .m}
menu .m
list [catch {.m insert 1 gorp} msg] $msg
} {1 {bad menu entry type "gorp": must be cascade, checkbutton, command, radiobutton, or separator}}
test menu-2.3 {MenuWidgetCmd procedure, "insert" option} {
catch {destroy .m}
menu .m
list [catch {.m insert none gorp} msg] $msg
} {1 {bad index "none"}}
test menu-2.4 {MenuWidgetCmd procedure, "insert" option} {
catch {destroy .m}
menu .m
.m add command -label first
.m insert 1 command -label second
.m insert 3 command -label third
.m insert 3 command -label fourth
list [.m entrycget 1 -label] [.m entrycget 2 -label] [.m entrycget 3 -label] [.m entrycget 4 -label]
} {second first fourth third}
catch {destroy .m}
menu .m
.m add command -label first
.m add command -label second
.m add command -label third
.m post 100 100
.m activate 2
update
test menu-3.1 {GetMenuIndex procedure} {
.m index active
} 2
test menu-3.2 {GetMenuIndex procedure} {
.m index last
} 3
test menu-3.3 {GetMenuIndex procedure} {
.m index end
} 3
test menu-3.4 {GetMenuIndex procedure} {
.m index none
} none
test menu-3.5 {GetMenuIndex procedure} {nonPortable} {
puts "running test"
.m index @13
} 0
test menu-3.6 {GetMenuIndex procedure} {nonPortable} {
.m index @14
} 1
test menu-3.7 {GetMenuIndex procedure} {
.m index @1000
} {3}
test menu-3.8 {GetMenuIndex procedure} {
.m index @-40
} {0}
test menu-3.9 {GetMenuIndex procedure} {
list [catch {.m index @foobar} msg] $msg
} {1 {bad menu entry index "@foobar"}}
test menu-3.10 {GetMenuIndex procedure} {
.m index first
} {1}
test menu-3.11 {GetMenuIndex procedure} {
.m index *d
} {2}
test menu-4.1 {MenuAddOrInsert procedure} {
catch {destroy .m}
menu .m
list [catch {.m insert foo gorp} msg] $msg
} {1 {bad menu entry index "foo"}}
test menu-4.2 {MenuAddOrInsert procedure} {
catch {destroy .m}
menu .m
.m add cascade
.m type last
} {cascade}
test menu-4.3 {MenuAddOrInsert procedure} {
catch {destroy .m}
menu .m
.m add checkbutton
.m type last
} {checkbutton}
test menu-4.4 {MenuAddOrInsert procedure} {
catch {destroy .m}
menu .m
.m add command
.m type last
} {command}
test menu-4.5 {MenuAddOrInsert procedure} {
catch {destroy .m}
menu .m
.m add radiobutton
.m type last
} {radiobutton}
test menu-4.6 {MenuAddOrInsert procedure} {
catch {destroy .m}
menu .m
.m add separator
.m type last
} {separator}
test menu-4.7 {MenuAddOrInsert procedure} {
catch {destroy .m}
menu .m
list [catch {.m add bogus} msg] $msg
} {1 {bad menu entry type "bogus": must be cascade, checkbutton, command, radiobutton, or separator}}
test menu-4.8 {MenuAddOrInsert procedure} {
catch {destroy .m}
menu .m
list [catch {.m add command -foo bar} msg] $msg
} {1 {unknown option "-foo"}}
test menu-4.9 {MenuAddOrInsert procedure} {
catch {destroy .m}
menu .m
.m add command -label first
.m add command -label second
.m add command -label third
.m add command -label fourth
catch {.m insert command -label new -bogus option}
list [.m entrycget 1 -label] [.m entrycget 2 -label] [.m entrycget 3 -label] [.m entrycget 4 -label]
} {first second third fourth}
test menu-5.1 {MenuVarProc, can't read variable} {
# This test does nothing but generate a core dump if there's a bug.
catch {destroy .m}
catch {unset a}
menu .m
set a(0) 44
.m add checkbutton -variable a
set a(1) 45
unset a
} {}
test menu-5.2 {ConfigureMenuEntry, setting background for separators and tearoffs} {
catch {destroy .m}
menu .m
.m add separator
.m entryconfig 0 -background "blue"
.m entryconfig 1 -background "green"
} {}
test menu-5.3 {ConfigureMenuEntry, setting background for separators and tearoffs returns error} {
catch {destroy .m}
menu .m
list [catch {.m entryconfig 0 -background "bogus"} msg] $msg
} {1 {unknown color name "bogus"}}