diff options
Diffstat (limited to 'tests/msgbox.test')
| -rw-r--r-- | tests/msgbox.test | 466 |
1 files changed, 96 insertions, 370 deletions
diff --git a/tests/msgbox.test b/tests/msgbox.test index 643ae2c..ec98c89 100644 --- a/tests/msgbox.test +++ b/tests/msgbox.test @@ -5,79 +5,65 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 +package require tcltest 2.1 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.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.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} +test msgbox-1.4 {tk_messageBox command} { + list [catch {tk_messageBox -default} msg] $msg +} {1 {value for "-default" missing}} -test msgbox-1.10 {tk_messageBox command} -body { - tk_messageBox -default -} -returnCodes error -result {value for "-default" missing} +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.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} +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.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.6 {tk_messageBox command} { + list [catch {tk_messageBox -default 1.1} msg] $msg +} [list 1 [createPlatformMsg "1.1"]] -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.7 {tk_messageBox command} { + list [catch {tk_messageBox -default foo} msg] $msg +} [list 1 [createPlatformMsg "foo"]] -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.8 {tk_messageBox command} { + list [catch {tk_messageBox -type yesno -default 3} msg] $msg +} [list 1 [createPlatformMsg "3"]] -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.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.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} { @@ -118,332 +104,72 @@ 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). # -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} +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 + } + 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} -constraints { - nonUnixUserInteraction -} -body { +test msgbox-3.1 {tk_messageBox handles withdrawn parent} nonUnixUserInteraction { wm withdraw . ChooseMsg . "ok" tk_messageBox -title Hi -message "Please press ok" \ -type ok -default ok -} -cleanup { - wm deiconify . -} -result {ok} +} "ok" +wm deiconify . -test msgbox-3.2 {tk_messageBox handles iconified parent} -constraints { - nonUnixUserInteraction -} -body { +test msgbox-3.2 {tk_messageBox handles iconified parent} nonUnixUserInteraction { wm iconify . ChooseMsg . "ok" tk_messageBox -title Hi -message "Please press ok" \ -type ok -default ok -} -cleanup { - wm deiconify . -} -result {ok} +} "ok" +wm deiconify . # cleanup cleanupTests return - - |