# 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. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # # RCS: @(#) $Id: menubut.test,v 1.1.1.1 2007/07/10 15:05:18 duncan 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. 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 # 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] if {[testConstraint testImageType]} { 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 "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 "badValue": must be above, below, flush, left, or right}} {-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 "1.5": must be flat, groove, raised, ridge, solid, or sunken}} {-state normal normal bogus {bad state "bogus": must be active, disabled, or normal}} {-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} testImageType { .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 {ambiguous 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] } {33} 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} testImageType { 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} {nonPortable 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 "badValue": must be above, below, flush, left, or right} below {}} # XXX Need to add tests for several procedures here. XXX test menubutton-5.1 {MenuButtonEventProc procedure} { deleteWindows 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} { deleteWindows menubutton .mb1 rename .mb1 {} list [info command .mb*] [winfo children .] } {{} {}} test menubutton-7.1 {ComputeMenuButtonGeometry procedure} testImageType { 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} testImageType { 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} testImageType { 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} testImageType { 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} testImageType { 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} {nonPortable 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} {testImageType unixOnly 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} {testImageType pcOnly 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] deleteWindows 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] deleteWindows option clear # cleanup ::tcltest::cleanupTests return