summaryrefslogtreecommitdiffstats
path: root/tests/msgbox.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/msgbox.test')
-rw-r--r--tests/msgbox.test466
1 files changed, 370 insertions, 96 deletions
diff --git a/tests/msgbox.test b/tests/msgbox.test
index ec98c89..643ae2c 100644
--- a/tests/msgbox.test
+++ b/tests/msgbox.test
@@ -5,65 +5,79 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
+namespace import -force tcltest::test
-test msgbox-1.1 {tk_messageBox command} {
- list [catch {tk_messageBox -foo} msg] $msg
-} {1 {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}}
-test msgbox-1.2 {tk_messageBox command} {
- list [catch {tk_messageBox -foo bar} msg] $msg
-} {1 {bad option "-foo": must be -default, -detail, -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] eq "-"} {
- test msgbox-1.3$option {tk_messageBox command} -body {
- tk_messageBox $option
- } -returnCodes error -result "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.1 {tk_messageBox command} -body {
+ tk_messageBox -foo
+} -returnCodes error -result {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}
+test msgbox-1.2 {tk_messageBox command} -body {
+ tk_messageBox -foo bar
+} -returnCodes error -result {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}
-test msgbox-1.5 {tk_messageBox command} {
- list [catch {tk_messageBox -type foo} msg] $msg
-} {1 {bad -type value "foo": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel}}
+test msgbox-1.3 {tk_messageBox command} -body {
+ tk_messageBox -default
+} -returnCodes error -result {value for "-default" missing}
+test msgbox-1.4 {tk_messageBox command} -body {
+ tk_messageBox -detail
+} -returnCodes error -result {value for "-detail" missing}
+test msgbox-1.5 {tk_messageBox command} -body {
+ tk_messageBox -icon
+} -returnCodes error -result {value for "-icon" missing}
+test msgbox-1.6 {tk_messageBox command} -body {
+ tk_messageBox -message
+} -returnCodes error -result {value for "-message" missing}
+test msgbox-1.7 {tk_messageBox command} -body {
+ tk_messageBox -parent
+} -returnCodes error -result {value for "-parent" missing}
+test msgbox-1.8 {tk_messageBox command} -body {
+ tk_messageBox -title
+} -returnCodes error -result {value for "-title" missing}
+test msgbox-1.9 {tk_messageBox command} -body {
+ tk_messageBox -type
+} -returnCodes error -result {value for "-type" missing}
-proc createPlatformMsg {val} {
- global tcl_platform
- if {$tcl_platform(platform) == "unix"} {
- return "invalid default button \"$val\""
- }
- return "bad -default value \"$val\": must be abort, retry, ignore, ok, cancel, no, or yes"
-}
+test msgbox-1.10 {tk_messageBox command} -body {
+ tk_messageBox -default
+} -returnCodes error -result {value for "-default" missing}
+
+test msgbox-1.11 {tk_messageBox command} -body {
+ tk_messageBox -type foo
+} -returnCodes error -result {bad -type value "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
-} [list 1 [createPlatformMsg "1.1"]]
+test msgbox-1.12 {tk_messageBox command} -constraints unix -body {
+ tk_messageBox -default 1.1
+} -returnCodes error -result {invalid default button "1.1"}
+test msgbox-1.13 {tk_messageBox command} -constraints macOrWin -body {
+ tk_messageBox -default 1.1
+} -returnCodes error -result {bad -default value "1.1": must be abort, retry, ignore, ok, cancel, no, or yes}
-test msgbox-1.7 {tk_messageBox command} {
- list [catch {tk_messageBox -default foo} msg] $msg
-} [list 1 [createPlatformMsg "foo"]]
+test msgbox-1.14 {tk_messageBox command} -constraints unix -body {
+ tk_messageBox -default foo
+} -returnCodes error -result {invalid default button "foo"}
+test msgbox-1.15 {tk_messageBox command} -constraints macOrWin -body {
+ tk_messageBox -default foo
+} -returnCodes error -result {bad -default value "foo": must be abort, retry, ignore, ok, cancel, no, or yes}
-test msgbox-1.8 {tk_messageBox command} {
- list [catch {tk_messageBox -type yesno -default 3} msg] $msg
-} [list 1 [createPlatformMsg "3"]]
+test msgbox-1.16 {tk_messageBox command} -constraints unix -body {
+ tk_messageBox -type yesno -default 3
+} -returnCodes error -result {invalid default button "3"}
+test msgbox-1.17 {tk_messageBox command} -constraints macOrWin -body {
+ tk_messageBox -type yesno -default 3
+} -returnCodes error -result {bad -default value "3": must be abort, retry, ignore, ok, cancel, no, or yes}
-test msgbox-1.9 {tk_messageBox command} {
- list [catch {tk_messageBox -icon foo} msg] $msg
-} {1 {bad -icon value "foo": must be error, info, question, or warning}}
+test msgbox-1.18 {tk_messageBox command} -body {
+ tk_messageBox -icon foo
+} -returnCodes error -result {bad -icon value "foo": must be error, info, question, or warning}
+test msgbox-1.19 {tk_messageBox command} -body {
+ tk_messageBox -parent foo.bar
+} -returnCodes error -result {bad window path name "foo.bar"}
-test msgbox-1.10 {tk_messageBox command} {
- list [catch {tk_messageBox -parent foo.bar} msg] $msg
-} {1 {bad window path name "foo.bar"}}
+catch {tk_messageBox -foo bar}
set isNative [expr {[info commands tk::MessageBox] == ""}]
proc ChooseMsg {parent btn} {
@@ -104,72 +118,332 @@ proc SendEventToMsg {parent btn type} {
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).
#
-set count 1
-foreach spec $specs {
- set type [lindex $spec 0]
- set buttons [lindex $spec 3]
-
- set button [lindex $buttons 0]
- test msgbox-2.$count {tk_messageBox command} nonUnixUserInteraction {
- ChooseMsg $parent $button
- tk_messageBox -title Hi -message "Please press $button" \
- -type $type
- } $button
- incr count
-
- foreach icon {warning error info question} {
- test msgbox-2.$count {tk_messageBox command -icon option} \
- nonUnixUserInteraction {
- ChooseMsg $parent $button
- tk_messageBox -title Hi -message "Please press $button" \
- -type $type -icon $icon
- } $button
- incr count
- }
+test msgbox-2.1 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . abort
+ tk_messageBox -title Hi -message "Please press abort" -type abortretryignore
+} -result {abort}
+test msgbox-2.2 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . abort
+ tk_messageBox -title Hi -message "Please press abort" \
+ -type abortretryignore -icon warning
+} -result {abort}
+test msgbox-2.3 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . abort
+ tk_messageBox -title Hi -message "Please press abort" \
+ -type abortretryignore -icon error
+} -result {abort}
+test msgbox-2.4 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . abort
+ tk_messageBox -title Hi -message "Please press abort" \
+ -type abortretryignore -icon info
+} -result {abort}
+test msgbox-2.5 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . abort
+ tk_messageBox -title Hi -message "Please press abort" \
+ -type abortretryignore -icon question
+} -result {abort}
+test msgbox-2.6 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . abort
+ tk_messageBox -title Hi -message "Please press abort" \
+ -type abortretryignore -default abort
+} -result {abort}
+test msgbox-2.7 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . retry
+ tk_messageBox -title Hi -message "Please press retry" \
+ -type abortretryignore -default retry
+} -result {retry}
+test msgbox-2.8 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ignore
+ tk_messageBox -title Hi -message "Please press ignore" \
+ -type abortretryignore -default ignore
+} -result {ignore}
+test msgbox-2.9 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" -type ok
+} -result {ok}
+test msgbox-2.10 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type ok -icon warning
+} -result {ok}
+test msgbox-2.11 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type ok -icon error
+} -result {ok}
+test msgbox-2.12 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type ok -icon info
+} -result {ok}
+test msgbox-2.13 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type ok -icon question
+} -result {ok}
+test msgbox-2.14 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type ok -default ok
+} -result {ok}
+test msgbox-2.15 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" -type okcancel
+} -result {ok}
+test msgbox-2.16 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type okcancel -icon warning
+} -result {ok}
+test msgbox-2.17 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type okcancel -icon error
+} -result {ok}
+test msgbox-2.18 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type okcancel -icon info
+} -result {ok}
+test msgbox-2.19 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type okcancel -icon question
+} -result {ok}
+test msgbox-2.20 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . ok
+ tk_messageBox -title Hi -message "Please press ok" \
+ -type okcancel -default ok
+} -result {ok}
+test msgbox-2.21 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . cancel
+ tk_messageBox -title Hi -message "Please press cancel" \
+ -type okcancel -default cancel
+} -result {cancel}
+test msgbox-2.22 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . retry
+ tk_messageBox -title Hi -message "Please press retry" -type retrycancel
+} -result {retry}
+test msgbox-2.23 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . retry
+ tk_messageBox -title Hi -message "Please press retry" \
+ -type retrycancel -icon warning
+} -result {retry}
+test msgbox-2.24 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . retry
+ tk_messageBox -title Hi -message "Please press retry" \
+ -type retrycancel -icon error
+} -result {retry}
+test msgbox-2.25 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . retry
+ tk_messageBox -title Hi -message "Please press retry" \
+ -type retrycancel -icon info
+} -result {retry}
+test msgbox-2.26 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . retry
+ tk_messageBox -title Hi -message "Please press retry" \
+ -type retrycancel -icon question
+} -result {retry}
+test msgbox-2.27 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . retry
+ tk_messageBox -title Hi -message "Please press retry" \
+ -type retrycancel -default retry
+} -result {retry}
+test msgbox-2.28 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . cancel
+ tk_messageBox -title Hi -message "Please press cancel" \
+ -type retrycancel -default cancel
+} -result {cancel}
+test msgbox-2.29 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" -type yesno
+} -result {yes}
+test msgbox-2.30 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesno -icon warning
+} -result {yes}
+test msgbox-2.31 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesno -icon error
+} -result {yes}
+test msgbox-2.32 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesno -icon info
+} -result {yes}
+test msgbox-2.33 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesno -icon question
+} -result {yes}
+test msgbox-2.34 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesno -default yes
+} -result {yes}
+test msgbox-2.35 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . no
+ tk_messageBox -title Hi -message "Please press no" \
+ -type yesno -default no
+} -result {no}
+test msgbox-2.36 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" -type yesnocancel
+} -result {yes}
+test msgbox-2.37 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesnocancel -icon warning
+} -result {yes}
+test msgbox-2.38 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesnocancel -icon error
+} -result {yes}
+test msgbox-2.39 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesnocancel -icon info
+} -result {yes}
+test msgbox-2.40 {tk_messageBox command -icon option} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesnocancel -icon question
+} -result {yes}
+test msgbox-2.41 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . yes
+ tk_messageBox -title Hi -message "Please press yes" \
+ -type yesnocancel -default yes
+} -result {yes}
+test msgbox-2.42 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . no
+ tk_messageBox -title Hi -message "Please press no" \
+ -type yesnocancel -default no
+} -result {no}
+test msgbox-2.43 {tk_messageBox command} -constraints {
+ nonUnixUserInteraction
+} -body {
+ ChooseMsg . cancel
+ tk_messageBox -title Hi -message "Please press cancel" \
+ -type yesnocancel -default cancel
+} -result {cancel}
- foreach button $buttons {
- test msgbox-2.$count {tk_messageBox command} nonUnixUserInteraction {
- ChooseMsg $parent $button
- tk_messageBox -title Hi -message "Please press $button" \
- -type $type -default $button
- } "$button"
- incr count
- }
-}
# These tests will hang your test suite if they fail.
-test msgbox-3.1 {tk_messageBox handles withdrawn parent} nonUnixUserInteraction {
+test msgbox-3.1 {tk_messageBox handles withdrawn parent} -constraints {
+ nonUnixUserInteraction
+} -body {
wm withdraw .
ChooseMsg . "ok"
tk_messageBox -title Hi -message "Please press ok" \
-type ok -default ok
-} "ok"
-wm deiconify .
+} -cleanup {
+ wm deiconify .
+} -result {ok}
-test msgbox-3.2 {tk_messageBox handles iconified parent} nonUnixUserInteraction {
+test msgbox-3.2 {tk_messageBox handles iconified parent} -constraints {
+ nonUnixUserInteraction
+} -body {
wm iconify .
ChooseMsg . "ok"
tk_messageBox -title Hi -message "Please press ok" \
-type ok -default ok
-} "ok"
-wm deiconify .
+} -cleanup {
+ wm deiconify .
+} -result {ok}
# cleanup
cleanupTests
return
+
+