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