158 lines
4.5 KiB
Plaintext
158 lines
4.5 KiB
Plaintext
# 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.3 96/09/26 09:23:15
|
|
#
|
|
|
|
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}}
|
|
|
|
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.3 {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.4 {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.5 {tk_messageBox command} {
|
|
ChooseMsg $parent $button
|
|
tk_messageBox -title Hi -message "Please press $button" \
|
|
-type $type -default $button
|
|
} "$button"
|
|
}
|
|
}
|
|
|