Subversion Repositories or1k

# This file is a Tcl script to test menubuttons in Tk.  It is

# organized in the standard fashion for Tcl tests.

#

# Copyright (c) 1994 The Regents of the University of California.

# Copyright (c) 1994-1996 Sun Microsystems, Inc.

#

# See the file "license.terms" for information on usage and redistribution

# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

#

# RCS: @(#) $Id: menubut.test,v 1.1.1.1 2002-01-16 10:25:59 markom Exp $

# XXX This test file is woefully incomplete right now.  If any part

# XXX of a procedure has tests then the whole procedure has tests,

# XXX but many procedures have no tests.

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?"

    return

}

if {[info procs test] != "test"} {

    source defs

}

foreach i [winfo children .] {

    destroy $i

}

wm geometry . {}

raise .

# Create entries in the option database to be sure that geometry options

# like border width have predictable values.

option add *Menubutton.borderWidth 2

option add *Menubutton.highlightThickness 2

option add *Menubutton.font {Helvetica -12 bold}

option add *Button.borderWidth 2

option add *Button.highlightThickness 2

option add *Button.font {Helvetica -12 bold}

eval image delete [image names]

image create test image1

menubutton .mb -text "Test"

pack .mb

update

set i 1

foreach test {

    {-activebackground #012345 #012345 non-existent

            {unknown color name "non-existent"}}

    {-activeforeground #ff0000 #ff0000 non-existent

            {unknown color name "non-existent"}}

    {-anchor nw nw bogus {bad anchor position "bogus": must be n, ne, e, se, s, sw, w, nw, or center}}

    {-background #ff0000 #ff0000 non-existent

            {unknown color name "non-existent"}}

    {-bd 4 4 badValue {bad screen distance "badValue"}}

    {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}}

    {-bitmap questhead questhead badValue {bitmap "badValue" not defined}}

    {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}

    {-cursor arrow arrow badValue {bad cursor spec "badValue"}}

    {-direction below below badValue {bad direction value "badValue": must be above, below, left, right, or flush}}

    {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"}}

    {-fg #110022 #110022 bogus {unknown color name "bogus"}}

    {-font {Helvetica 12} {Helvetica 12} {} {font "" doesn't exist}}

    {-foreground #110022 #110022 bogus {unknown color name "bogus"}}

    {-height 18 18 20.0 {expected integer but got "20.0"}}

    {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}}

    {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"}}

    {-highlightthickness 18 18 badValue {bad screen distance "badValue"}}

    {-image image1 image1 bogus {image "bogus" doesn't exist}}

    {-indicatoron yes 1 no_way {expected boolean value but got "no_way"}}

    {-justify right right bogus {bad justification "bogus": must be left, right, or center}}

    {-menu "any old string" "any old string" {} {}}

    {-padx 12 12 420x {bad screen distance "420x"}}

    {-pady 12 12 420x {bad screen distance "420x"}}

    {-relief groove groove 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}}

    {-state normal normal bogus {bad state value "bogus": must be normal, active, or disabled}}

    {-takefocus "any string" "any string" {} {}}

    {-text "Sample text" {Sample text} {} {}}

    {-textvariable i i {} {}}

    {-underline 5 5 3p {expected integer but got "3p"}}

    {-width 402 402 3p {expected integer but got "3p"}}

    {-wraplength 100 100 6x {bad screen distance "6x"}}

} {

    set name [lindex $test 0]

    test menubutton-1.$i {configuration options} {

        .mb configure $name [lindex $test 1]

        lindex [.mb configure $name] 4

    } [lindex $test 2]

    incr i

    if {[lindex $test 3] != ""} {

        test menubutton-1.$i {configuration options} {

            list [catch {.mb configure $name [lindex $test 3]} msg] $msg

        } [list 1 [lindex $test 4]]

    }

    .mb configure $name [lindex [.mb configure $name] 3]

    incr i

}

test menubutton-2.1 {Tk_MenubuttonCmd procedure} {

    list [catch {menubutton} msg] $msg

} {1 {wrong # args: should be "menubutton pathName ?options?"}}

test menubutton-2.2 {Tk_MenubuttonCmd procedure} {

    list [catch {menubutton foo} msg] $msg

} {1 {bad window path name "foo"}}

test menubutton-2.3 {Tk_MenubuttonCmd procedure} {

    catch {destroy .mb}

    menubutton .mb

    winfo class .mb

} {Menubutton}

test menubutton-2.4 {Tk_ButtonCmd procedure} {

    catch {destroy .mb}

    list [catch {menubutton .mb -gorp foo} msg] $msg [winfo exists .mb]

} {1 {unknown option "-gorp"} 0}

catch {destroy .mb}

menubutton .mb -text "Test Menu"

pack .mb

test menubutton-3.1 {MenuButtonWidgetCmd procedure} {

    list [catch {.mb} msg] $msg

} {1 {wrong # args: should be ".mb option ?arg arg ...?"}}

test menubutton-3.2 {ButtonWidgetCmd procedure, "cget" option} {

    list [catch {.mb c} msg] $msg

} {1 {bad option "c": must be cget or configure}}

test menubutton-3.3 {ButtonWidgetCmd procedure, "cget" option} {

    list [catch {.mb cget} msg] $msg

} {1 {wrong # args: should be ".mb cget option"}}

test menubutton-3.4 {ButtonWidgetCmd procedure, "cget" option} {

    list [catch {.mb cget a b} msg] $msg

} {1 {wrong # args: should be ".mb cget option"}}

test menubutton-3.5 {ButtonWidgetCmd procedure, "cget" option} {

    list [catch {.mb cget -gorp} msg] $msg

} {1 {unknown option "-gorp"}}

test menubutton-3.6 {ButtonWidgetCmd procedure, "cget" option} {

    .mb configure -highlightthickness 3

    .mb cget -highlightthickness

} {3}

test menubutton-3.7 {ButtonWidgetCmd procedure, "configure" option} {

    llength [.mb configure]

} {32}

test menubutton-3.8 {ButtonWidgetCmd procedure, "configure" option} {

    list [catch {.mb configure -gorp} msg] $msg

} {1 {unknown option "-gorp"}}

test menubutton-3.9 {ButtonWidgetCmd procedure, "configure" option} {

    list [catch {.mb co -bg #ffffff -fg} msg] $msg

} {1 {value for "-fg" missing}}

test menubutton-3.10 {ButtonWidgetCmd procedure, "configure" option} {

    .mb configure -fg #123456

    .mb configure -bg #654321

    lindex [.mb configure -fg] 4

} {#123456}

test menubutton-3.11 {ButtonWidgetCmd procedure, "configure" option} {

    list [catch {.mb foobar} msg] $msg

} {1 {bad option "foobar": must be cget or configure}}

# XXX Need to add tests for several procedures here.   The tests for   XXX

# XXX ConfigureMenuButton aren't complete either.                      XXX

test menubutton-4.1 {ConfigureMenuButton procedure} {

    catch {destroy .mb1}

    button .mb1 -text "Menubutton 1"

    list [catch {.mb1 configure -width 1i} msg] $msg $errorInfo

} {1 {expected integer but got "1i"} {expected integer but got "1i"

    (processing -width option)

    invoked from within

".mb1 configure -width 1i"}}

test menubutton-4.2 {ConfigureMenuButton procedure} {

    catch {destroy .mb1}

    button .mb1 -text "Menubutton 1"

    list [catch {.mb1 configure -height 0.5c} msg] $msg $errorInfo

} {1 {expected integer but got "0.5c"} {expected integer but got "0.5c"

    (processing -height option)

    invoked from within

".mb1 configure -height 0.5c"}}

test menubutton-4.3 {ConfigureMenuButton procedure} {

    catch {destroy .mb1}

    button .mb1 -bitmap questhead

    list [catch {.mb1 configure -width abc} msg] $msg $errorInfo

} {1 {bad screen distance "abc"} {bad screen distance "abc"

    (processing -width option)

    invoked from within

".mb1 configure -width abc"}}

test menubutton-4.4 {ConfigureMenuButton procedure} {

    catch {destroy .mb1}

    eval image delete [image names]

    image create test image1

    button .mb1 -image image1

    list [catch {.mb1 configure -height 0.5x} msg] $msg $errorInfo

} {1 {bad screen distance "0.5x"} {bad screen distance "0.5x"

    (processing -height option)

    invoked from within

".mb1 configure -height 0.5x"}}

test menubutton-4.5 {ConfigureMenuButton procedure} {fonts} {

    catch {destroy .mb1}

    button .mb1 -text "Sample text" -width 10 -height 2

    pack .mb1

    set result "[winfo reqwidth .mb1] [winfo reqheight .mb1]"

    .mb1 configure -bitmap questhead

    lappend result [winfo reqwidth .mb1] [winfo reqheight .mb1]

} {102 46 20 12}

test menubutton-4.6 {ConfigureMenuButton procedure - bad direction} {

    catch {destroy .mb}

    menubutton .mb -text "Test"

    list [catch {.mb configure -direction badValue} msg] $msg \

        [.mb cget -direction] [destroy .mb]

} {1 {bad direction value "badValue": must be above, below, left, right, or flush} below {}}

# XXX Need to add tests for several procedures here. XXX

test menubutton-5.1 {MenuButtonEventProc procedure} {

    eval destroy [winfo children .]

    menubutton .mb1 -bg #543210

    rename .mb1 .mb2

    set x {}

    lappend x [winfo children .]

    lappend x [.mb2 cget -bg]

    destroy .mb1

    lappend x [info command .mb*] [winfo children .]

} {.mb1 #543210 {} {}}

test menubutton-6.1 {MenuButtonCmdDeletedProc procedure} {

    eval destroy [winfo children .]

    menubutton .mb1

    rename .mb1 {}

    list [info command .mb*] [winfo children .]

} {{} {}}

test menubutton-7.1 {ComputeMenuButtonGeometry procedure} {

    catch {destroy .mb}

    menubutton .mb -image image1 -bd 4 -highlightthickness 0

    pack .mb

    list [winfo reqwidth .mb] [winfo reqheight .mb]

} {38 23}

test menubutton-7.2 {ComputeMenuButtonGeometry procedure} {

    catch {destroy .mb}

    menubutton .mb -image image1 -bd 1 -highlightthickness 2

    pack .mb

    list [winfo reqwidth .mb] [winfo reqheight .mb]

} {36 21}

test menubutton-7.3 {ComputeMenuButtonGeometry procedure} {

    catch {destroy .mb}

    menubutton .mb -image image1 -bd 0 -highlightthickness 2 -padx 5 -pady 5

    pack .mb

    list [winfo reqwidth .mb] [winfo reqheight .mb]

} {34 19}

test menubutton-7.4 {ComputeMenuButtonGeometry procedure} {

    catch {destroy .mb}

    menubutton .mb -image image1 -bd 2 -relief raised -width 40 \

            -highlightthickness 2

    pack .mb

    list [winfo reqwidth .mb] [winfo reqheight .mb]

} {48 23}

test menubutton-7.5 {ComputeMenuButtonGeometry procedure} {

    catch {destroy .mb}

    menubutton .mb -image image1 -bd 2 -relief raised -height 30 \

            -highlightthickness 2

    pack .mb

    list [winfo reqwidth .mb] [winfo reqheight .mb]

} {38 38}

test menubutton-7.6 {ComputeMenuButtonGeometry procedure} {

    catch {destroy .mb}

    menubutton .mb -bitmap question -bd 2 -relief raised \

            -highlightthickness 2

    pack .mb

    list [winfo reqwidth .mb] [winfo reqheight .mb]

} {25 35}

test menubutton-7.7 {ComputeMenuButtonGeometry procedure} {

    catch {destroy .mb}

    menubutton .mb -bitmap question -bd 2 -relief raised -width 40 \

            -highlightthickness 1

    pack .mb

    list [winfo reqwidth .mb] [winfo reqheight .mb]

} {46 33}

test menubutton-7.8 {ComputeMenuButtonGeometry procedure} {

    catch {destroy .mb}

    menubutton .mb -bitmap question -bd 2 -relief raised -height 50 \

            -highlightthickness 1

    pack .mb

    list [winfo reqwidth .mb] [winfo reqheight .mb]

} {23 56}

test menubutton-7.9 {ComputeMenuButtonGeometry procedure} {fonts} {

    catch {destroy .mb}

    menubutton .mb -text String -bd 2 -relief raised -padx 0 -pady 0 \

            -highlightthickness 1

    pack .mb

    list [winfo reqwidth .mb] [winfo reqheight .mb]

} {42 20}

test menubutton-7.10 {ComputeMenuButtonGeometry procedure} {fonts} {

    catch {destroy .mb}

    menubutton .mb -text String -bd 2 -relief raised -width 20 \

            -padx 0 -pady 0 -highlightthickness 1

    pack .mb

    list [winfo reqwidth .mb] [winfo reqheight .mb]

} {146 20}

test menubutton-7.11 {ComputeMenuButtonGeometry procedure} {fonts} {

    catch {destroy .mb}

    menubutton .mb -text String -bd 2 -relief raised -height 2 \

            -padx 0 -pady 0 -highlightthickness 1

    pack .mb

    list [winfo reqwidth .mb] [winfo reqheight .mb]

} {42 34}

test menubutton-7.12 {ComputeMenuButtonGeometry procedure} {fonts} {

    catch {destroy .mb}

    menubutton .mb -text String -bd 2 -relief raised -padx 10 -pady 5 \

            -highlightthickness 1

    pack .mb

    list [winfo reqwidth .mb] [winfo reqheight .mb]

} {62 30}

test menubutton-7.13 {ComputeMenuButtonGeometry procedure} {fonts} {

    catch {destroy .mb}

    menubutton .mb -text String -bd 2 -relief raised \

            -highlightthickness 1 -indicatoron 1

    pack .mb

    list [winfo reqwidth .mb] [winfo reqheight .mb]

} {78 28}

test menubutton-7.14 {ComputeMenuButtonGeometry procedure} {unix nonPortable} {

    # The following test is non-portable because the indicator's pixel

    # size varies to maintain constant absolute size.

    catch {destroy .mb}

    menubutton .mb -image image1 -bd 2 -relief raised \

            -highlightthickness 2 -indicatoron 1

    pack .mb

    list [winfo reqwidth .mb] [winfo reqheight .mb]

} {64 23}

test menubutton-7.15 {ComputeMenuButtonGeometry procedure} {pc nonPortable} {

    # The following test is non-portable because the indicator's pixel

    # size varies to maintain constant absolute size.

    catch {destroy .mb}

    menubutton .mb -image image1 -bd 2 -relief raised \

            -highlightthickness 2 -indicatoron 1

    pack .mb

    list [winfo reqwidth .mb] [winfo reqheight .mb]

} {65 23}

set l [interp hidden]

eval destroy [winfo children .]

test menubutton-8.1 {menubutton vs hidden commands} {

    catch {destroy .mb}

    menubutton .mb

    interp hide {} .mb

    destroy .mb

    list [winfo children .] [interp hidden]

} [list {} $l]

eval image delete [image names]

eval destroy [winfo children .]

option clear