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
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
|
# This file is a Tcl script to test out the procedures in the file
# tkCursor.c. It is organized in the standard white-box fashion for
# Tcl tests.
#
# Copyright (c) 1998 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.1
eval tcltest::configure $argv
tcltest::loadTestedCommands
test cursor-1.1 {Tk_AllocCursorFromObj - converting internal reps} {testcursor} {
set x watch
lindex $x 0
destroy .b1
button .b1 -cursor $x
lindex $x 0
testcursor watch
} {{1 0}}
test cursor-1.2 {Tk_AllocCursorFromObj - discard stale cursor} {testcursor} {
set x watch
destroy .b1 .b2
button .b1 -cursor $x
destroy .b1
set result {}
lappend result [testcursor watch]
button .b2 -cursor $x
lappend result [testcursor watch]
} {{} {{1 1}}}
test cursor-1.3 {Tk_AllocCursorFromObj - reuse existing cursor} {testcursor} {
set x watch
destroy .b1 .b2
button .b1 -cursor $x
set result {}
lappend result [testcursor watch]
button .b2 -cursor $x
pack .b1 .b2 -side top
lappend result [testcursor watch]
} {{{1 1}} {{2 1}}}
test cursor-2.1 {Tk_GetCursor procedure} {
destroy .b1
list [catch {button .b1 -cursor bad_name} msg] $msg
} {1 {bad cursor spec "bad_name"}}
test cursor-2.2 {Tk_GetCursor procedure} {
destroy .b1
list [catch {button .b1 -cursor @xyzzy} msg] $msg
} {1 {bad cursor spec "@xyzzy"}}
# Next two tests need a helper file with a very specific name and
# controlled format.
set wincur(data_octal) {
000 000 002 000 001 000 040 040 000 000 007 000 007 000 060 001
000 000 026 000 000 000 050 000 000 000 040 000 000 000 100 000
000 000 001 000 001 000 000 000 000 000 000 000 000 000 000 000
000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
000 000 377 377 377 000 000 000 000 000 000 000 000 000 000 000
000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
000 000 000 000 000 000 000 000 000 000 160 016 000 000 170 036
000 000 174 076 000 000 076 174 000 000 037 370 000 000 017 360
000 000 007 340 000 000 007 340 000 000 017 360 000 000 037 370
000 000 076 174 000 000 174 076 000 000 170 036 000 000 160 016
000 000 000 000 000 000 377 377 377 377 377 377 377 377 377 377
377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377
377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377
377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377
377 377 377 377 377 377 017 360 377 377 007 340 377 377 003 300
377 377 001 200 377 377 200 001 377 377 300 003 377 377 340 007
377 377 360 017 377 377 360 017 377 377 340 007 377 377 300 003
377 377 200 001 377 377 001 200 377 377 003 300 377 377 007 340
377 377 017 360 377 377
}
set wincur(data_binary) {}
foreach wincur(num) $wincur(data_octal) {
append wincur(data_binary) [binary format c [scan $wincur(num) %o]]
}
set wincur(dir) [makeDirectory {dir with spaces}]
set wincur(file) [makeFile $wincur(data_binary) "test file.cur" $wincur(dir)]
test cursor-2.3 {Tk_GetCursor procedure: cursor specs are lists} win {
destroy .b1
button .b1 -cursor [list @$wincur(file)]
} {.b1}
test cursor-2.4 {Tk_GetCursor procedure: cursor specs are lists} win {
destroy .b1
button .b1 -cursor @[regsub -all {[][ \\{}""$#]} $wincur(file) {\\&}]
} {.b1}
removeDirectory $wincur(dir)
unset wincur
test cursor-3.1 {Tk_FreeCursorFromObj - reference counts} {testcursor} {
set x heart
destroy .b1 .b2 .b3
button .b1 -cursor $x
button .b3 -cursor $x
button .b2 -cursor $x
set result {}
lappend result [testcursor heart]
destroy .b1
lappend result [testcursor heart]
destroy .b2
lappend result [testcursor heart]
destroy .b3
lappend result [testcursor heart]
} {{{3 1}} {{2 1}} {{1 1}} {}}
test cursor-4.1 {FreeCursorObjProc} {testcursor} {
destroy .b
set x [format heart]
button .b -cursor $x
set y [format heart]
.b configure -cursor $y
set z [format heart]
.b configure -cursor $z
set result {}
lappend result [testcursor heart]
set x red
lappend result [testcursor heart]
set z 32
lappend result [testcursor heart]
destroy .b
lappend result [testcursor heart]
set y bogus
set result
} {{{1 3}} {{1 2}} {{1 1}} {}}
# -------------------------------------------------------------------------
test cursor-5.1 {assert consistent cursor configuration command} -setup {
button .b
} -body {
.b configure -cursor {watch red black}
} -cleanup {
destroy .b
} -result {}
# -------------------------------------------------------------------------
# Check for the standard set of cursors.
foreach {testName cursor} {
cursor-6.1 X_cursor
cursor-6.2 arrow
cursor-6.3 based_arrow_down
cursor-6.4 based_arrow_up
cursor-6.5 boat
cursor-6.6 bogosity
cursor-6.7 bottom_left_corner
cursor-6.8 bottom_right_corner
cursor-6.9 bottom_side
cursor-6.10 bottom_tee
cursor-6.11 box_spiral
cursor-6.12 center_ptr
cursor-6.13 circle
cursor-6.14 clock
cursor-6.15 coffee_mug
cursor-6.16 cross
cursor-6.17 cross_reverse
cursor-6.18 crosshair
cursor-6.19 diamond_cross
cursor-6.20 dot
cursor-6.21 dotbox
cursor-6.22 double_arrow
cursor-6.23 draft_large
cursor-6.24 draft_small
cursor-6.25 draped_box
cursor-6.26 exchange
cursor-6.27 fleur
cursor-6.28 gobbler
cursor-6.29 gumby
cursor-6.30 hand1
cursor-6.31 hand2
cursor-6.32 heart
cursor-6.33 icon
cursor-6.34 iron_cross
cursor-6.35 left_ptr
cursor-6.36 left_side
cursor-6.37 left_tee
cursor-6.38 leftbutton
cursor-6.39 ll_angle
cursor-6.40 lr_angle
cursor-6.41 man
cursor-6.42 middlebutton
cursor-6.43 mouse
cursor-6.44 pencil
cursor-6.45 pirate
cursor-6.46 plus
cursor-6.47 question_arrow
cursor-6.48 right_ptr
cursor-6.49 right_side
cursor-6.50 right_tee
cursor-6.51 rightbutton
cursor-6.52 rtl_logo
cursor-6.53 sailboat
cursor-6.54 sb_down_arrow
cursor-6.55 sb_h_double_arrow
cursor-6.56 sb_left_arrow
cursor-6.57 sb_right_arrow
cursor-6.58 sb_up_arrow
cursor-6.59 sb_v_double_arrow
cursor-6.60 shuttle
cursor-6.61 sizing
cursor-6.62 spider
cursor-6.63 spraycan
cursor-6.64 star
cursor-6.65 target
cursor-6.66 tcross
cursor-6.67 top_left_arrow
cursor-6.68 top_left_corner
cursor-6.69 top_right_corner
cursor-6.70 top_side
cursor-6.71 top_tee
cursor-6.72 trek
cursor-6.73 ul_angle
cursor-6.74 umbrella
cursor-6.75 ur_angle
cursor-6.76 watch
cursor-6.77 xterm
} {
test $testName "check cursor-font cursor $cursor" -setup {
button .b -text $cursor
} -body {
.b configure -cursor $cursor
} -cleanup {
destroy .b
} -result {}
}
# Test cursor named "none", it is not defined in
# the X cursor table. It is defined in a Tk specific
# table of named cursors and should be available on
# all platforms.
test cursor-6.80 {} -setup {
button .b -text CButton
} -body {
.b configure -cursor none
.b cget -cursor
} -cleanup {
destroy .b
} -result none
test cursor-6.81 {} -setup {
button .b -text CButton
} -body {
.b configure -cursor none
.b configure -cursor {}
.b cget -cursor
} -cleanup {
destroy .b
} -result {}
test cursor-6.82 {} -setup {
button .b -text CButton
} -body {
.b configure -cursor none
.b configure -cursor {}
.b configure -cursor none
.b cget -cursor
} -cleanup {
destroy .b
} -result none
test cursor-6.83 {} -setup {
button .b -text CButton
} -body {
# Setting fg and bg does nothing for the none cursor
# because it displays no fg or bg pixels.
set results [list]
.b configure -cursor none
lappend results [.b cget -cursor]
.b configure -cursor {none blue}
lappend results [.b cget -cursor]
.b configure -cursor {none blue green}
lappend results [.b cget -cursor]
.b configure -cursor {}
lappend results [.b cget -cursor]
set results
} -cleanup {
destroy .b
unset results
} -result {none {none blue} {none blue green} {}}
# -------------------------------------------------------------------------
# Check the Windows specific cursors
foreach {testName cursor} {
cursor-7.1 no
cursor-7.2 starting
cursor-7.3 size
cursor-7.4 size_ne_sw
cursor-7.5 size_ns
cursor-7.6 size_nw_se
cursor-7.7 size_we
cursor-7.8 uparrow
cursor-7.9 wait
} {
test $testName "check Windows cursor $cursor" -constraints win -setup {
button .b -text $cursor
} -body {
.b configure -cursor $cursor
} -cleanup {
destroy .b
} -result {}
}
# -------------------------------------------------------------------------
destroy .t
# cleanup
cleanupTests
return
|
