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