summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/message.test122
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