summaryrefslogtreecommitdiffstats
path: root/tests/msgbox.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/msgbox.test')
-rw-r--r--tests/msgbox.test157
1 files changed, 157 insertions, 0 deletions
diff --git a/tests/msgbox.test b/tests/msgbox.test
new file mode 100644
index 0000000..c23ddaf
--- /dev/null
+++ b/tests/msgbox.test
@@ -0,0 +1,157 @@
+# This file is a Tcl script to test out Tk's "tk_messageBox" command.
+# It is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 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.
+#
+# SCCS: @(#) msgbox.test 1.7 97/07/31 10:05:25
+#
+
+if {[string compare test [info procs test]] == 1} {
+ source defs
+}
+
+test msgbox-1.1 {tk_messageBox command} {
+ list [catch {tk_messageBox -foo} msg] $msg
+} {1 {unknown option "-foo", must be -default, -icon, -message, -parent, -title or -type}}
+test msgbox-1.2 {tk_messageBox command} {
+ list [catch {tk_messageBox -foo bar} msg] $msg
+} {1 {unknown option "-foo", must be -default, -icon, -message, -parent, -title or -type}}
+
+catch {tk_messageBox -foo bar} msg
+regsub -all , $msg "" options
+regsub \"-foo\" $options "" options
+
+foreach option $options {
+ if {[string index $option 0] == "-"} {
+ test msgbox-1.3 {tk_messageBox command} {
+ list [catch {tk_messageBox $option} msg] $msg
+ } [list 1 "value for \"$option\" missing"]
+ }
+}
+
+test msgbox-1.4 {tk_messageBox command} {
+ list [catch {tk_messageBox -default} msg] $msg
+} {1 {value for "-default" missing}}
+
+test msgbox-1.5 {tk_messageBox command} {
+ list [catch {tk_messageBox -type foo} msg] $msg
+} {1 {invalid message box type "foo", must be abortretryignore, ok, okcancel, retrycancel, yesno or yesnocancel}}
+
+test msgbox-1.6 {tk_messageBox command} {
+ list [catch {tk_messageBox -default 1.1} msg] $msg
+} {1 {invalid default button "1.1"}}
+
+test msgbox-1.7 {tk_messageBox command} {
+ list [catch {tk_messageBox -default foo} msg] $msg
+} {1 {invalid default button "foo"}}
+
+test msgbox-1.8 {tk_messageBox command} {
+ list [catch {tk_messageBox -type yesno -default 3} msg] $msg
+} {1 {invalid default button "3"}}
+
+test msgbox-1.9 {tk_messageBox command} {
+ list [catch {tk_messageBox -icon foo} msg] $msg
+} {1 {invalid icon "foo", must be error, info, question or warning}}
+
+test msgbox-1.10 {tk_messageBox command} {
+ list [catch {tk_messageBox -parent foo.bar} msg] $msg
+} {1 {bad window path name "foo.bar"}}
+
+if {[info commands tkMessageBox] == ""} {
+ set isNative 1
+} else {
+ set isNative 0
+}
+
+if {$isNative && ![info exists INTERACTIVE]} {
+ puts " Some tests were skipped because they could not be performed"
+ puts " automatically on this platform. If you wish to execute them"
+ puts " interactively, set the TCL variable INTERACTIVE and re-run"
+ puts " the test"
+ return
+}
+
+proc ChooseMsg {parent btn} {
+ global isNative
+ if {!$isNative} {
+ after 100 SendEventToMsg $parent $btn mouse
+ }
+}
+
+proc ChooseMsgByKey {parent btn} {
+ global isNative
+ if {!$isNative} {
+ after 100 SendEventToMsg $parent $btn key
+ }
+}
+
+proc PressButton {btn} {
+ event generate $btn <Enter>
+ event generate $btn <ButtonPress-1> -x 5 -y 5
+ event generate $btn <ButtonRelease-1> -x 5 -y 5
+}
+
+proc SendEventToMsg {parent btn type} {
+ if {$parent != "."} {
+ set w $parent.__tk__messagebox
+ } else {
+ set w .__tk__messagebox
+ }
+ if ![winfo ismapped $w.$btn] {
+ update
+ }
+ if {$type == "mouse"} {
+ PressButton $w.$btn
+ } else {
+ event generate $w <Enter>
+ focus $w
+ event generate $w.$btn <Enter>
+ event generate $w <KeyPress> -keysym Return
+ }
+}
+
+set parent .
+
+set specs {
+ {"abortretryignore" MB_ABORTRETRYIGNORE 3 {"abort" "retry" "ignore"}}
+ {"ok" MB_OK 1 {"ok" }}
+ {"okcancel" MB_OKCANCEL 2 {"ok" "cancel" }}
+ {"retrycancel" MB_RETRYCANCEL 2 {"retry" "cancel" }}
+ {"yesno" MB_YESNO 2 {"yes" "no" }}
+ {"yesnocancel" MB_YESNOCANCEL 3 {"yes" "no" "cancel"}}
+}
+
+#
+# Try out all combinations of (type) x (default button) and
+# (type) x (icon).
+#
+foreach spec $specs {
+ set type [lindex $spec 0]
+ set buttons [lindex $spec 3]
+
+ set button [lindex $buttons 0]
+ test msgbox-2.1 {tk_messageBox command} {
+ ChooseMsg $parent $button
+ tk_messageBox -title Hi -message "Please press $button" \
+ -type $type
+ } $button
+
+ foreach icon {warning error info question} {
+ test msgbox-2.2 {tk_messageBox command -icon option} {
+ ChooseMsg $parent $button
+ tk_messageBox -title Hi -message "Please press $button" \
+ -type $type -icon $icon
+ } $button
+ }
+
+ foreach button $buttons {
+ test msgbox-2.3 {tk_messageBox command} {
+ ChooseMsg $parent $button
+ tk_messageBox -title Hi -message "Please press $button" \
+ -type $type -default $button
+ } "$button"
+ }
+}