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
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
|
# Tests for the grab command.
#
# This file contains a collection of tests for one or more of the Tk
# built-in commands. Sourcing this file runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright © 1998-2000 by Ajuba Solutions.
# All rights reserved.
package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
# The macOS test module includes the pressbutton command to simulate a
# mouse button press event by injecting events into the NSApplication
# event queue. On other platforms there is currently no way to test
# the actual grab effect, per se, in an automated test. Therefore,
# this test suite only covers the interface to the grab command (ie,
# error messages, etc.) on platforms other than macOS.
testConstraint pressbutton [llength [info commands pressbutton]]
test grab-1.1 {Tk_GrabObjCmd} -body {
grab
} -returnCodes error -result {wrong # args: should be "grab ?-global? window" or "grab option ?arg ...?"}
test grab-1.2 {Tk_GrabObjCmd} -body {
rename grab grabTest1.2
grabTest1.2
} -cleanup {
rename grabTest1.2 grab
} -returnCodes error -result {wrong # args: should be "grabTest1.2 ?-global? window" or "grabTest1.2 option ?arg ...?"}
test grab-1.3 {Tk_GrabObjCmd, "grab ?-global? window"} -body {
grab .foo bar baz
} -returnCodes error -result {wrong # args: should be "grab ?-global? window"}
test grab-1.4 {Tk_GrabObjCmd, "grab ?-global? window"} -body {
destroy .foo
grab .foo
} -returnCodes error -result {bad window path name ".foo"}
test grab-1.5 {Tk_GrabObjCmd, "grab ?-global? window"} -body {
grab -foo bar
} -returnCodes error -result {bad option "-foo": must be -global}
test grab-1.6 {Tk_GrabObjCmd, "grab ?-global? window"} -body {
destroy .foo
grab -global .foo
} -returnCodes error -result {bad window path name ".foo"}
test grab-1.7 {Tk_GrabObjCmd} -body {
grab foo
} -returnCodes error -result {bad option "foo": must be current, release, set, or status}
test grab-1.8 {Tk_GrabObjCmd, "grab current ?window?"} -body {
grab current foo bar
} -returnCodes error -result {wrong # args: should be "grab current ?window?"}
test grab-1.9 {Tk_GrabObjCmd, "grab current ?window?"} -body {
destroy .foo
grab current .foo
} -returnCodes error -result {bad window path name ".foo"}
test grab-1.10 {Tk_GrabObjCmd, "grab release window"} -body {
grab release
} -returnCodes error -result {wrong # args: should be "grab release window"}
test grab-1.11 {Tk_GrabObjCmd, "grab release window"} -body {
destroy .foo
grab release .foo
} -returnCodes ok -result {}
test grab-1.12 {Tk_GrabObjCmd, "grab release window"} -body {
grab release foo
} -returnCodes ok -result {}
test grab-1.13 {Tk_GrabObjCmd, "grab set ?-global? window"} -body {
grab set
} -returnCodes error -result {wrong # args: should be "grab set ?-global? window"}
test grab-1.14 {Tk_GrabObjCmd, "grab set ?-global? window"} -body {
grab set foo bar baz
} -returnCodes error -result {wrong # args: should be "grab set ?-global? window"}
test grab-1.15 {Tk_GrabObjCmd, "grab set ?-global? window"} -body {
destroy .foo
grab set .foo
} -returnCodes error -result {bad window path name ".foo"}
test grab-1.16 {Tk_GrabObjCmd, "grab set ?-global? window"} -body {
grab set -foo bar
} -returnCodes error -result {bad option "-foo": must be -global}
test grab-1.17 {Tk_GrabObjCmd, "grab set ?-global? window"} -body {
destroy .foo
grab set -global .foo
} -returnCodes error -result {bad window path name ".foo"}
test grab-1.18 {Tk_GrabObjCmd, "grab status window"} -body {
grab status
} -returnCodes error -result {wrong # args: should be "grab status window"}
test grab-1.19 {Tk_GrabObjCmd, "grab status window"} -body {
grab status foo bar
} -returnCodes error -result {wrong # args: should be "grab status window"}
test grab-1.20 {Tk_GrabObjCmd, "grab status window"} -body {
destroy .foo
grab status .foo
} -returnCodes error -result {bad window path name ".foo"}
test grab-2.1 {Tk_GrabObjCmd, grab status gives correct status} -body {
set curr [grab current .]
if { [string length $curr] > 0 } {
grab release $curr
}
grab status .
} -cleanup {
grab release .
} -result none
test grab-2.2 {Tk_GrabObjCmd, grab status gives correct status} -body {
set curr [grab current .]
if { [string length $curr] > 0 } {
grab release $curr
}
grab .
grab status .
} -cleanup {
grab release .
} -result {local}
test grab-2.3 {Tk_GrabObjCmd, grab status gives correct status} -body {
set curr [grab current .]
if { [string length $curr] > 0 } {
grab release $curr
}
grab -global .
grab status .
} -cleanup {
grab release .
} -result {global}
test grab-3.1 {Tk_GrabObjCmd, grab current gives correct information} -body {
set curr [grab current .]
if { [string length $curr] > 0 } {
grab release $curr
}
return $curr
} -result {}
test grab-3.2 {Tk_GrabObjCmd, grab current gives correct information} -body {
set curr [grab current .]
if { [string length $curr] > 0 } {
grab release $curr
}
grab .
grab current
} -cleanup {
grab release .
} -result {.}
test grab-4.1 {Tk_GrabObjCmd, grab release releases grab} -body {
set curr [grab current .]
if { [string length $curr] > 0 } {
grab release $curr
}
grab .
set result [grab status .]
grab release .
lappend result [grab status .]
grab -global .
lappend result [grab status .]
grab release .
lappend result [grab status .]
} -result {local none global none}
test grab-5.1 {Tk_GrabObjCmd, grab set} -body {
set curr [grab current .]
if { [string length $curr] > 0 } {
grab release $curr
}
grab set .
list [grab current .] [grab status .]
} -cleanup {
grab release .
} -result {. local}
test grab-5.2 {Tk_GrabObjCmd, grab set} -body {
set curr [grab current .]
if { [string length $curr] > 0 } {
grab release $curr
}
grab set -global .
list [grab current .] [grab status .]
} -cleanup {
grab release .
} -result {. global}
test grab-6.1 {local grab on child window} -constraints {
pressbutton
} -body {
wm geometry . 100x200+200+100
set result {}
frame .f -background red -padx 10 -pady 10 -height 100 -width 80
bind . <Button-1> {lappend result "outside"}
bind .f <Button-1> {lappend result "inside"}
pack .f
update idletasks
pressbutton 250 150
update
lappend result ":"
pressbutton 250 250
update
lappend result ":"
grab set .f
pressbutton 250 150
update
lappend result ":"
pressbutton 250 250
update
return $result
} -cleanup {
grab release .f
} -result {inside outside : outside : inside outside :}
cleanupTests
return
|
