archie/tk4.2/tests/menu.test

# 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"}}