1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
|
# 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.
#
# RCS: @(#) $Id: msgbox.test,v 1.4 2000/04/18 02:18:34 ericm Exp $
#
if {[lsearch [namespace children] ::tcltest] == -1} {
source [file join [pwd] [file dirname [info script]] defs.tcl]
}
# Some tests require user interaction on non-unix platform
set ::tcltest::testConfig(nonUnixUserInteraction) \
[expr {$::tcltest::testConfig(userInteraction) || \
$::tcltest::testConfig(unixOnly)}]
test msgbox-1.1 {tk_messageBox command} {
list [catch {tk_messageBox -foo} msg] $msg
} {1 {bad 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 {bad option "-foo": must be -default, -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] == "-"} {
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 {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.6 {tk_messageBox command} {
list [catch {tk_messageBox -default 1.1} msg] $msg
} [list 1 [createPlatformMsg "1.1"]]
test msgbox-1.7 {tk_messageBox command} {
list [catch {tk_messageBox -default foo} msg] $msg
} [list 1 [createPlatformMsg "foo"]]
test msgbox-1.8 {tk_messageBox command} {
list [catch {tk_messageBox -type yesno -default 3} msg] $msg
} [list 1 [createPlatformMsg "3"]]
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"}}
if {[info commands tkMessageBox] == ""} {
set isNative 1
} else {
set isNative 0
}
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).
#
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} {nonUnixUserInteraction} {
wm withdraw .
ChooseMsg . "ok"
tk_messageBox -title Hi -message "Please press ok" \
-type ok -default ok
} "ok"
wm deiconify .
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
} "ok"
wm deiconify .
# cleanup
::tcltest::cleanupTests
return
|
