diff options
Diffstat (limited to 'tests/message.test')
| -rw-r--r-- | tests/message.test | 122 |
1 files changed, 122 insertions, 0 deletions
diff --git a/tests/message.test b/tests/message.test new file mode 100644 index 0000000..f2c7d5d --- /dev/null +++ b/tests/message.test @@ -0,0 +1,122 @@ +# This file is a Tcl script to test out the "message" command +# of 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-2000 by Ajuba Solutions. +# All rights reserved. +# +# RCS: @(#) $Id: message.test,v 1.1 2000/08/02 01:33:34 ericm Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +option add *Message.borderWidth 2 +option add *Message.highlightThickness 2 +option add *Message.font {Helvetica -12 bold} + +message .m +pack .m +update +set i 0 +foreach test { + {-anchor w w bogus {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}} + {-aspect 3 3 bogus {expected integer but got "bogus"}} + {-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"}} + {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} + {-cursor arrow arrow badValue {bad cursor spec "badValue"}} + {-fg #00ff00 #00ff00 badValue {unknown color name "badValue"}} + {-font fixed fixed {} {font "" doesn't exist}} + {-foreground green green badValue {unknown color name "badValue"}} + {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} + {-highlightcolor #123456 #123456 non-existent + {unknown color name "non-existent"}} + {-highlightthickness 2 2 badValue {bad screen distance "badValue"}} + {-justify right right bogus {bad justification "bogus": must be left, right, or center}} + {-padx 12m 12m 420x {bad screen distance "420x"}} + {-pady 12m 12m 420x {bad screen distance "420x"}} + {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}} + {-text "Sample text" {Sample text} {} {} {1 1 1 1}} + {-textvariable i i {} {} {1 1 1 1}} + {-width 32 32 badValue {bad screen distance "badValue"}} +} { + set name [lindex $test 0] + test message-1.$i {configuration options} { + .m configure $name [lindex $test 1] + lindex [.m configure $name] 4 + } [lindex $test 2] + incr i + if {[lindex $test 3] != ""} { + test message-1.$i {configuration options} { + list [catch {.m configure $name [lindex $test 3]} msg] $msg + } [list 1 [lindex $test 4]] + } + .m configure $name [lindex [.m configure $name] 3] + incr i +} +destroy .m + +test message-2.1 {Tk_MessageObjCmd procedure} { + list [catch {message} msg] $msg +} {1 {wrong # args: should be "message pathName ?options?"}} +test message-2.2 {Tk_MessageObjCmd procedure} { + list [catch {message foo} msg] $msg [winfo child .] +} {1 {bad window path name "foo"} {}} +test message-2.3 {Tk_MessageObjCmd procedure} { + list [catch {message .s -gorp dumb} msg] $msg [winfo child .] +} {1 {unknown option "-gorp"} {}} + +test message-3.1 {MessageWidgetObjCmd procedure} { + message .m + set result [list [catch {.m} msg] $msg] + destroy .m + set result +} {1 {wrong # args: should be ".m option ?arg arg ...?"}} +test message-3.2 {MessageWidgetObjCmd procedure, "cget"} { + message .m + set result [list [catch {.m cget} msg] $msg] + destroy .m + set result +} {1 {wrong # args: should be ".m cget option"}} +test message-3.3 {MessageWidgetObjCmd procedure, "cget"} { + message .m + set result [list [catch {.m cget -gorp} msg] $msg] + destroy .m + set result +} {1 {unknown option "-gorp"}} +test message-3.4 {MessageWidgetObjCmd procedure, "cget"} { + message .m + .m configure -text foobar + set result [.m cget -text] + destroy .m + set result +} "foobar" +test message-3.5 {MessageWidgetObjCmd procedure, "configure"} { + message .m + set result [llength [.m configure]] + destroy .m + set result +} 21 +test message-3.6 {MessageWidgetObjCmd procedure, "configure"} { + message .m + set result [list [catch {.m configure -foo} msg] $msg] + destroy .m + set result +} {1 {unknown option "-foo"}} +test message-3.7 {MessageWidgetObjCmd procedure, "configure"} { + message .m + .m configure -bd 4 + .m configure -bg #ffffff + set result [lindex [.m configure -bd] 4] + destroy .m + set result +} {4} + +# cleanup +::tcltest::cleanupTests +return |