diff options
Diffstat (limited to 'tests/msgbox.test')
| -rw-r--r-- | tests/msgbox.test | 157 |
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" + } +} |