1# This file is a Tcl script to test out the procedures in the file
2# tkCursor.c.  It is organized in the standard white-box fashion for
3# Tcl tests.
4#
5# Copyright (c) 1998 Sun Microsystems, Inc.
6# Copyright (c) 1998-1999 by Scriptics Corporation.
7# All rights reserved.
8#
9# RCS: @(#) $Id$
10
11package require tcltest 2.1
12eval tcltest::configure $argv
13tcltest::loadTestedCommands
14
15test cursor-1.1 {Tk_AllocCursorFromObj - converting internal reps} {testcursor} {
16    set x watch
17    lindex $x 0
18    destroy .b1
19    button .b1 -cursor $x
20    lindex $x 0
21    testcursor watch
22} {{1 0}}
23test cursor-1.2 {Tk_AllocCursorFromObj - discard stale cursor} {testcursor} {
24    set x watch
25    destroy .b1 .b2
26    button .b1 -cursor $x
27    destroy .b1
28    set result {}
29    lappend result [testcursor watch]
30    button .b2 -cursor $x
31    lappend result [testcursor watch]
32} {{} {{1 1}}}
33test cursor-1.3 {Tk_AllocCursorFromObj - reuse existing cursor} {testcursor} {
34    set x watch
35    destroy .b1 .b2
36    button .b1 -cursor $x
37    set result {}
38    lappend result [testcursor watch]
39    button .b2 -cursor $x
40    pack .b1 .b2 -side top
41    lappend result [testcursor watch]
42} {{{1 1}} {{2 1}}}
43
44test cursor-2.1 {Tk_GetCursor procedure} {
45    destroy .b1
46    list [catch {button .b1 -cursor bad_name} msg] $msg
47} {1 {bad cursor spec "bad_name"}}
48test cursor-2.2 {Tk_GetCursor procedure} {
49    destroy .b1
50    list [catch {button .b1 -cursor @xyzzy} msg] $msg
51} {1 {bad cursor spec "@xyzzy"}}
52# Next two tests need a helper file with a very specific name and
53# controlled format.
54set wincur(data_octal) {
55    000 000 002 000 001 000 040 040 000 000 007 000 007 000 060 001
56    000 000 026 000 000 000 050 000 000 000 040 000 000 000 100 000
57    000 000 001 000 001 000 000 000 000 000 000 000 000 000 000 000
58    000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
59    000 000 377 377 377 000 000 000 000 000 000 000 000 000 000 000
60    000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
61    000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
62    000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
63    000 000 000 000 000 000 000 000 000 000 160 016 000 000 170 036
64    000 000 174 076 000 000 076 174 000 000 037 370 000 000 017 360
65    000 000 007 340 000 000 007 340 000 000 017 360 000 000 037 370
66    000 000 076 174 000 000 174 076 000 000 170 036 000 000 160 016
67    000 000 000 000 000 000 377 377 377 377 377 377 377 377 377 377
68    377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377
69    377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377
70    377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377
71    377 377 377 377 377 377 017 360 377 377 007 340 377 377 003 300
72    377 377 001 200 377 377 200 001 377 377 300 003 377 377 340 007
73    377 377 360 017 377 377 360 017 377 377 340 007 377 377 300 003
74    377 377 200 001 377 377 001 200 377 377 003 300 377 377 007 340
75    377 377 017 360 377 377
76}
77set wincur(data_binary) {}
78foreach wincur(num) $wincur(data_octal) {
79    append wincur(data_binary) [binary format c [scan $wincur(num) %o]]
80}
81set wincur(dir) [makeDirectory {dir with spaces}]
82set wincur(file) [makeFile $wincur(data_binary) "test file.cur" $wincur(dir)]
83test cursor-2.3 {Tk_GetCursor procedure: cursor specs are lists} win {
84    destroy .b1
85    button .b1 -cursor [list @$wincur(file)]
86} {.b1}
87test cursor-2.4 {Tk_GetCursor procedure: cursor specs are lists} win {
88    destroy .b1
89    button .b1 -cursor @[regsub -all {[][ \\{}""$#]} $wincur(file) {\\&}]
90} {.b1}
91removeDirectory $wincur(dir)
92unset wincur
93
94test cursor-3.1 {Tk_FreeCursorFromObj - reference counts} {testcursor} {
95    set x heart
96    destroy .b1 .b2 .b3
97    button .b1 -cursor $x
98    button .b3 -cursor $x
99    button .b2 -cursor $x
100    set result {}
101    lappend result [testcursor heart]
102    destroy .b1
103    lappend result [testcursor heart]
104    destroy .b2
105    lappend result [testcursor heart]
106    destroy .b3
107    lappend result [testcursor heart]
108} {{{3 1}} {{2 1}} {{1 1}} {}}
109
110test cursor-4.1 {FreeCursorObjProc} {testcursor} {
111    destroy .b
112    set x [format heart]
113    button .b -cursor $x
114    set y [format heart]
115    .b configure -cursor $y
116    set z [format heart]
117    .b configure -cursor $z
118    set result {}
119    lappend result [testcursor heart]
120    set x red
121    lappend result [testcursor heart]
122    set z 32
123    lappend result [testcursor heart]
124    destroy .b
125    lappend result [testcursor heart]
126    set y bogus
127    set result
128} {{{1 3}} {{1 2}} {{1 1}} {}}
129
130# -------------------------------------------------------------------------
131
132test cursor-5.1 {assert consistent cursor configuration command} -setup {
133    button .b
134} -body {
135    .b configure -cursor {watch red black}
136} -cleanup {
137    destroy .b
138} -result {}
139
140# -------------------------------------------------------------------------
141# Check for the standard set of cursors.
142
143foreach {testName cursor} {
144    cursor-6.1  X_cursor
145    cursor-6.2  arrow
146    cursor-6.3  based_arrow_down
147    cursor-6.4  based_arrow_up
148    cursor-6.5  boat
149    cursor-6.6  bogosity
150    cursor-6.7  bottom_left_corner
151    cursor-6.8  bottom_right_corner
152    cursor-6.9  bottom_side
153    cursor-6.10 bottom_tee
154    cursor-6.11 box_spiral
155    cursor-6.12 center_ptr
156    cursor-6.13 circle
157    cursor-6.14 clock
158    cursor-6.15 coffee_mug
159    cursor-6.16 cross
160    cursor-6.17 cross_reverse
161    cursor-6.18 crosshair
162    cursor-6.19 diamond_cross
163    cursor-6.20 dot
164    cursor-6.21 dotbox
165    cursor-6.22 double_arrow
166    cursor-6.23 draft_large
167    cursor-6.24 draft_small
168    cursor-6.25 draped_box
169    cursor-6.26 exchange
170    cursor-6.27 fleur
171    cursor-6.28 gobbler
172    cursor-6.29 gumby
173    cursor-6.30 hand1
174    cursor-6.31 hand2
175    cursor-6.32 heart
176    cursor-6.33 icon
177    cursor-6.34 iron_cross
178    cursor-6.35 left_ptr
179    cursor-6.36 left_side
180    cursor-6.37 left_tee
181    cursor-6.38 leftbutton
182    cursor-6.39 ll_angle
183    cursor-6.40 lr_angle
184    cursor-6.41 man
185    cursor-6.42 middlebutton
186    cursor-6.43 mouse
187    cursor-6.44 pencil
188    cursor-6.45 pirate
189    cursor-6.46 plus
190    cursor-6.47 question_arrow
191    cursor-6.48 right_ptr
192    cursor-6.49 right_side
193    cursor-6.50 right_tee
194    cursor-6.51 rightbutton
195    cursor-6.52 rtl_logo
196    cursor-6.53 sailboat
197    cursor-6.54 sb_down_arrow
198    cursor-6.55 sb_h_double_arrow
199    cursor-6.56 sb_left_arrow
200    cursor-6.57 sb_right_arrow
201    cursor-6.58 sb_up_arrow
202    cursor-6.59 sb_v_double_arrow
203    cursor-6.60 shuttle
204    cursor-6.61 sizing
205    cursor-6.62 spider
206    cursor-6.63 spraycan
207    cursor-6.64 star
208    cursor-6.65 target
209    cursor-6.66 tcross
210    cursor-6.67 top_left_arrow
211    cursor-6.68 top_left_corner
212    cursor-6.69 top_right_corner
213    cursor-6.70 top_side
214    cursor-6.71 top_tee
215    cursor-6.72 trek
216    cursor-6.73 ul_angle
217    cursor-6.74 umbrella
218    cursor-6.75 ur_angle
219    cursor-6.76 watch
220    cursor-6.77 xterm
221} {
222    test $testName "check cursor-font cursor $cursor" -setup {
223	button .b -text $cursor
224    } -body {
225	.b configure -cursor $cursor
226    } -cleanup {
227	destroy .b
228    } -result {}
229}
230
231# Test cursor named "none", it is not defined in
232# the X cursor table. It is defined in a Tk specific
233# table of named cursors and should be available on
234# all platforms.
235
236test cursor-6.80 {} -setup {
237    button .b -text CButton
238} -body {
239    .b configure -cursor none
240    .b cget -cursor
241} -cleanup {
242    destroy .b
243} -result none
244
245test cursor-6.81 {} -setup {
246    button .b -text CButton
247} -body {
248    .b configure -cursor none
249    .b configure -cursor {}
250    .b cget -cursor
251} -cleanup {
252    destroy .b
253} -result {}
254
255test cursor-6.82 {} -setup {
256    button .b -text CButton
257} -body {
258    .b configure -cursor none
259    .b configure -cursor {}
260    .b configure -cursor none
261    .b cget -cursor
262} -cleanup {
263    destroy .b
264} -result none
265
266test cursor-6.83 {} -setup {
267    button .b -text CButton
268} -body {
269    # Setting fg and bg does nothing for the none cursor
270    # because it displays no fg or bg pixels.
271    set results [list]
272    .b configure -cursor none
273    lappend results [.b cget -cursor]
274    .b configure -cursor {none blue}
275    lappend results [.b cget -cursor]
276    .b configure -cursor {none blue green}
277    lappend results [.b cget -cursor]
278    .b configure -cursor {}
279    lappend results [.b cget -cursor]
280    set results
281} -cleanup {
282    destroy .b
283    unset results
284} -result {none {none blue} {none blue green} {}}
285
286# -------------------------------------------------------------------------
287# Check the Windows specific cursors
288
289foreach {testName cursor} {
290    cursor-7.1 no
291    cursor-7.2 starting
292    cursor-7.3 size
293    cursor-7.4 size_ne_sw
294    cursor-7.5 size_ns
295    cursor-7.6 size_nw_se
296    cursor-7.7 size_we
297    cursor-7.8 uparrow
298    cursor-7.9 wait
299} {
300    test $testName "check Windows cursor $cursor" -constraints win -setup {
301	button .b -text $cursor
302    } -body {
303	.b configure -cursor $cursor
304    } -cleanup {
305	destroy .b
306    } -result {}
307}
308
309# -------------------------------------------------------------------------
310
311destroy .t
312
313# cleanup
314cleanupTests
315return
316