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: cursor.test,v 1.8.2.1 2004/01/28 23:37:23 patthoyts Exp $
10
11package require tcltest 2.1
12namespace import -force tcltest::configure
13namespace import -force tcltest::testsDirectory
14configure -testdir [file join [pwd] [file dirname [info script]]]
15configure -loadfile [file join [testsDirectory] constraints.tcl]
16tcltest::loadTestedCommands
17
18testConstraint testcursor [llength [info commands testcursor]]
19
20test cursor-1.1 {Tk_AllocCursorFromObj - converting internal reps} {testcursor} {
21    set x watch
22    lindex $x 0
23    destroy .b1
24    button .b1 -cursor $x
25    lindex $x 0
26    testcursor watch
27} {{1 0}}
28test cursor-1.2 {Tk_AllocCursorFromObj - discard stale cursor} {testcursor} {
29    set x watch
30    destroy .b1 .b2
31    button .b1 -cursor $x
32    destroy .b1
33    set result {}
34    lappend result [testcursor watch]
35    button .b2 -cursor $x
36    lappend result [testcursor watch]
37} {{} {{1 1}}}
38test cursor-1.3 {Tk_AllocCursorFromObj - reuse existing cursor} {testcursor} {
39    set x watch
40    destroy .b1 .b2
41    button .b1 -cursor $x
42    set result {}
43    lappend result [testcursor watch]
44    button .b2 -cursor $x
45    pack .b1 .b2 -side top
46    lappend result [testcursor watch]
47} {{{1 1}} {{2 1}}}
48
49test cursor-2.1 {Tk_GetCursor procedure} {
50    destroy .b1
51    list [catch {button .b1 -cursor bad_name} msg] $msg
52} {1 {bad cursor spec "bad_name"}}
53test cursor-2.2 {Tk_GetCursor procedure} {
54    destroy .b1
55    list [catch {button .b1 -cursor @xyzzy} msg] $msg
56} {1 {bad cursor spec "@xyzzy"}}
57# Next two tests need a helper file with a very specific name and
58# controlled format.
59set wincur(data_octal) {
60    000 000 002 000 001 000 040 040 000 000 007 000 007 000 060 001
61    000 000 026 000 000 000 050 000 000 000 040 000 000 000 100 000
62    000 000 001 000 001 000 000 000 000 000 000 000 000 000 000 000
63    000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
64    000 000 377 377 377 000 000 000 000 000 000 000 000 000 000 000
65    000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
66    000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
67    000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
68    000 000 000 000 000 000 000 000 000 000 160 016 000 000 170 036
69    000 000 174 076 000 000 076 174 000 000 037 370 000 000 017 360
70    000 000 007 340 000 000 007 340 000 000 017 360 000 000 037 370
71    000 000 076 174 000 000 174 076 000 000 170 036 000 000 160 016
72    000 000 000 000 000 000 377 377 377 377 377 377 377 377 377 377
73    377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377
74    377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377
75    377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377
76    377 377 377 377 377 377 017 360 377 377 007 340 377 377 003 300
77    377 377 001 200 377 377 200 001 377 377 300 003 377 377 340 007
78    377 377 360 017 377 377 360 017 377 377 340 007 377 377 300 003
79    377 377 200 001 377 377 001 200 377 377 003 300 377 377 007 340
80    377 377 017 360 377 377
81}
82set wincur(data_binary) {}
83foreach wincur(num) $wincur(data_octal) {
84    append wincur(data_binary) [binary format c 0$wincur(num)]
85}
86set wincur(dir) [::tcltest::makeDirectory {dir with spaces}]
87set wincur(file) [::tcltest::makeFile $wincur(data_binary) "test file.cur" $wincur(dir)]
88test cursor-2.3 {Tk_GetCursor procedure: cursor specs are lists} {pcOnly} {
89    destroy .b1
90    button .b1 -cursor [list @$wincur(file)]
91} {.b1}
92test cursor-2.4 {Tk_GetCursor procedure: cursor specs are lists} {pcOnly} {
93    destroy .b1
94    button .b1 -cursor @[regsub -all {[][ \\{}""$#]} $wincur(file) {\\&}]
95} {.b1}
96::tcltest::removeDirectory $wincur(dir)
97unset wincur
98
99test cursor-3.1 {Tk_FreeCursorFromObj - reference counts} {testcursor} {
100    set x heart
101    destroy .b1 .b2 .b3
102    button .b1 -cursor $x
103    button .b3 -cursor $x
104    button .b2 -cursor $x
105    set result {}
106    lappend result [testcursor heart]
107    destroy .b1
108    lappend result [testcursor heart]
109    destroy .b2
110    lappend result [testcursor heart]
111    destroy .b3
112    lappend result [testcursor heart]
113} {{{3 1}} {{2 1}} {{1 1}} {}}
114
115test cursor-4.1 {FreeCursorObjProc} {testcursor} {
116    destroy .b
117    set x [format heart]
118    button .b -cursor $x
119    set y [format heart]
120    .b configure -cursor $y
121    set z [format heart]
122    .b configure -cursor $z
123    set result {}
124    lappend result [testcursor heart]
125    set x red
126    lappend result [testcursor heart]
127    set z 32
128    lappend result [testcursor heart]
129    destroy .b
130    lappend result [testcursor heart]
131    set y bogus
132    set result
133} {{{1 3}} {{1 2}} {{1 1}} {}}
134
135# -------------------------------------------------------------------------
136
137test cursor-5.1 {assert consistent cursor configuration command} \
138    -setup { button .b } \
139    -body {
140        list [catch {.b configure -cursor {watch red black}} msg] $msg
141    } \
142    -cleanup {destroy .b} \
143    -result {0 {}}
144
145# -------------------------------------------------------------------------
146# Check for the standard set of cursors.
147
148set n 0
149foreach cursor {
150    X_cursor
151    arrow
152    based_arrow_down
153    based_arrow_up
154    boat
155    bogosity
156    bottom_left_corner
157    bottom_right_corner
158    bottom_side
159    bottom_tee
160    box_spiral
161    center_ptr
162    circle
163    clock
164    coffee_mug
165    cross
166    cross_reverse
167    crosshair
168    diamond_cross
169    dot
170    dotbox
171    double_arrow
172    draft_large
173    draft_small
174    draped_box
175    exchange
176    fleur
177    gobbler
178    gumby
179    hand1
180    hand2
181    heart
182    icon
183    iron_cross
184    left_ptr
185    left_side
186    left_tee
187    leftbutton
188    ll_angle
189    lr_angle
190    man
191    middlebutton
192    mouse
193    pencil
194    pirate
195    plus
196    question_arrow
197    right_ptr
198    right_side
199    right_tee
200    rightbutton
201    rtl_logo
202    sailboat
203    sb_down_arrow
204    sb_h_double_arrow
205    sb_left_arrow
206    sb_right_arrow
207    sb_up_arrow
208    sb_v_double_arrow
209    shuttle
210    sizing
211    spider
212    spraycan
213    star
214    target
215    tcross
216    top_left_arrow
217    top_left_corner
218    top_right_corner
219    top_side
220    top_tee
221    trek
222    ul_angle
223    umbrella
224    ur_angle
225    watch
226    xterm
227} {
228    test cursor-6.$n {check cursor $cursor} \
229        -setup {button .b -text $cursor} \
230        -body {
231            list [catch {.b configure -cursor $cursor} msg] $msg
232        } \
233        -cleanup {destroy .b} \
234        -result {0 {}}
235    incr n
236}
237unset n
238
239# -------------------------------------------------------------------------
240# Check the Windows specific cursors
241set n 0
242foreach cursor {
243    no
244    starting
245    size
246    size_ne_sw
247    size_ns
248    size_nw_se
249    size_we
250    uparrow
251    wait
252} {
253    test cursor-7.$n {check cursor $cursor} \
254        -constraints {pcOnly} \
255        -setup {button .b -text $cursor} \
256        -body {
257            list [catch {.b configure -cursor $cursor} msg] $msg
258        } \
259        -cleanup {destroy .b} \
260        -result {0 {}}
261    incr n
262}
263unset n
264
265# -------------------------------------------------------------------------
266# Check the Mac specific cursors
267set n 0
268foreach cursor {
269    text
270    cross-hair
271} {
272    test cursor-8.$n {check cursor $cursor} \
273        -constraints {macOnly} \
274        -setup {button .b -text $cursor} \
275        -body {
276            list [catch {.b configure -cursor $cursor} msg] $msg
277        } \
278        -cleanup {destroy .b} \
279        -result {0 {}}
280    incr n
281}
282unset n
283
284# -------------------------------------------------------------------------
285
286destroy .t
287
288# cleanup
289::tcltest::cleanupTests
290return
291