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