diff options
Diffstat (limited to 'tk8.6/tests/msgbox.test')
| -rw-r--r-- | tk8.6/tests/msgbox.test | 449 |
1 files changed, 0 insertions, 449 deletions
diff --git a/tk8.6/tests/msgbox.test b/tk8.6/tests/msgbox.test deleted file mode 100644 index 643ae2c..0000000 --- a/tk8.6/tests/msgbox.test +++ /dev/null @@ -1,449 +0,0 @@ -# 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. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# All rights reserved. - -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test - - -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.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.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.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.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.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"} - - -catch {tk_messageBox -foo bar} -set isNative [expr {[info commands tk::MessageBox] == ""}] - -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 - } -} -# -# 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} - - -# These tests will hang your test suite if they fail. -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 -} -cleanup { - wm deiconify . -} -result {ok} - -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 -} -cleanup { - wm deiconify . -} -result {ok} - -# cleanup -cleanupTests -return - - |