1# This file is a Tcl script to test out the procedures in tkRectOval.c, 2# which implement canvas "rectangle" and "oval" items. It is organized 3# in the standard fashion for Tcl tests. 4# 5# Copyright (c) 1994-1996 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 15canvas .c -width 400 -height 300 -bd 2 -relief sunken 16pack .c 17bind .c <1> { 18 puts "button down at (%x,%y)" 19} 20update 21 22set i 1 23.c create rectangle 20 20 80 80 -tag test 24foreach test { 25 {-fill #ff0000 #ff0000 26 non-existent {unknown color name "non-existent"}} 27 {-outline #123456 #123456 28 bad_color {unknown color name "bad_color"}} 29 {-stipple gray50 gray50 30 bogus {bitmap "bogus" not defined}} 31 {-tags {test a b c} {test a b c} 32 {} {}} 33 {-width 6.0 6.0 34 abc {bad screen distance "abc"}} 35} { 36 lassign $test name goodValue goodResult badValue badResult 37 test canvRect-1.$i "configuration options: good value for $name" { 38 .c itemconfigure test $name $goodValue 39 list [lindex [.c itemconfigure test $name] 4] [.c itemcget test $name] 40 } [list $goodResult $goodResult] 41 incr i 42 if {$badValue ne ""} { 43 test canvRect-1.$i "configuration options: bad value for $name" -body { 44 .c itemconfigure test $name $badValue 45 } -returnCodes error -result $badResult 46 } 47 incr i 48} 49test canvRect-1.$i {configuration options} { 50 .c itemconfigure test -tags {test xyz} 51 .c itemcget xyz -tags 52} {test xyz} 53 54test canvRect-2.1 {CreateRectOval procedure} { 55 list [catch {.c create rect} msg] $msg 56} {1 {wrong # args: should be ".c create rect coords ?arg arg ...?"}} 57test canvRect-2.2 {CreateRectOval procedure} { 58 list [catch {.c create oval x y z} msg] $msg 59} {1 {wrong # coordinates: expected 0 or 4, got 3}} 60test canvRect-2.3 {CreateRectOval procedure} { 61 list [catch {.c create rectangle x 2 3 4} msg] $msg 62} {1 {bad screen distance "x"}} 63test canvRect-2.4 {CreateRectOval procedure} { 64 list [catch {.c create rectangle 1 y 3 4} msg] $msg 65} {1 {bad screen distance "y"}} 66test canvRect-2.5 {CreateRectOval procedure} { 67 list [catch {.c create rectangle 1 2 z 4} msg] $msg 68} {1 {bad screen distance "z"}} 69test canvRect-2.6 {CreateRectOval procedure} { 70 list [catch {.c create rectangle 1 2 3 q} msg] $msg 71} {1 {bad screen distance "q"}} 72test canvRect-2.7 {CreateRectOval procedure} { 73 .c create rectangle 1 2 3 4 -tags x 74 set result {} 75 foreach element [.c coords x] { 76 lappend result [format %.1f $element] 77 } 78 set result 79} {1.0 2.0 3.0 4.0} 80test canvRect-2.8 {CreateRectOval procedure} { 81 list [catch {.c create rectangle 1 2 3 4 -gorp foo} msg] $msg 82} {1 {unknown option "-gorp"}} 83 84.c delete withtag all 85.c create rectangle 10 20 30 40 -tags x 86test canvRect-3.1 {RectOvalCoords procedure} { 87 set result {} 88 foreach element [.c coords x] { 89 lappend result [format %.1f $element] 90 } 91 set result 92} {10.0 20.0 30.0 40.0} 93test canvRect-3.2 {RectOvalCoords procedure} { 94 list [catch {.c coords x a 2 3 4} msg] $msg 95} {1 {bad screen distance "a"}} 96test canvRect-3.3 {RectOvalCoords procedure} { 97 list [catch {.c coords x 1 b 3 4} msg] $msg 98} {1 {bad screen distance "b"}} 99test canvRect-3.4 {RectOvalCoords procedure} { 100 list [catch {.c coords x 1 2 c 4} msg] $msg 101} {1 {bad screen distance "c"}} 102test canvRect-3.5 {RectOvalCoords procedure} { 103 list [catch {.c coords x 1 2 3 d} msg] $msg 104} {1 {bad screen distance "d"}} 105test canvRect-3.6 {RectOvalCoords procedure} {nonPortable} { 106 # Non-portable due to rounding differences. 107 .c coords x 10 25 15 40 108 .c bbox x 109} {9 24 16 41} 110test canvRect-3.7 {RectOvalCoords procedure} { 111 list [catch {.c coords x 1 2 3 4 5} msg] $msg 112} {1 {wrong # coordinates: expected 0 or 4, got 5}} 113 114.c delete withtag all 115.c create rectangle 10 20 30 40 -tags x -width 1 116test canvRect-4.1 {ConfigureRectOval procedure} { 117 list [catch {.c itemconfigure x -width abc} msg] $msg \ 118 [.c itemcget x -width] 119} {1 {bad screen distance "abc"} 1.0} 120test canvRect-4.2 {ConfigureRectOval procedure} { 121 list [catch {.c itemconfigure x -width -5} msg] $msg 122} {1 {bad screen distance "-5"}} 123test canvRect-4.3 {ConfigureRectOval procedure} {nonPortable} { 124 # Non-portable due to rounding differences. 125 .c itemconfigure x -width 10 126 .c bbox x 127} {5 15 35 45} 128# I can't come up with any good tests for DeleteRectOval. 129 130.c delete withtag all 131.c create rectangle 10 20 30 40 -tags x -width 1 -outline {} 132test canvRect-5.1 {ComputeRectOvalBbox procedure} {nonPortable} { 133 # Non-portable due to rounding differences: 134 .c coords x 20 15 10 5 135 .c bbox x 136} {10 5 20 15} 137test canvRect-5.2 {ComputeRectOvalBbox procedure} {nonPortable} { 138 # Non-portable due to rounding differences: 139 .c coords x 10 20 30 10 140 .c itemconfigure x -width 1 -outline red 141 .c bbox x 142} {9 9 31 21} 143test canvRect-5.3 {ComputeRectOvalBbox procedure} {nonPortable} { 144 # Non-portable due to rounding differences: 145 .c coords x 10 20 30 10 146 .c itemconfigure x -width 2 -outline red 147 .c bbox x 148} {9 9 31 21} 149test canvRect-5.4 {ComputeRectOvalBbox procedure} {nonPortable} { 150 # Non-portable due to rounding differences: 151 .c coords x 10 20 30 10 152 .c itemconfigure x -width 3 -outline red 153 .c bbox x 154} {8 8 32 22} 155 156# I can't come up with any good tests for DisplayRectOval. 157 158.c delete withtag all 159set x [.c create rectangle 10 20 30 35 -tags x -fill green] 160set y [.c create rectangle 15 25 25 30 -tags y -fill red] 161test canvRect-6.1 {RectToPoint procedure} { 162 .c itemconfigure y -outline {} 163 list [.c find closest 14.9 28] [.c find closest 15.1 28] \ 164 [.c find closest 24.9 28] [.c find closest 25.1 28] 165} "$x $y $y $x" 166test canvRect-6.2 {RectToPoint procedure} { 167 .c itemconfigure y -outline {} 168 list [.c find closest 20 24.9] [.c find closest 20 25.1] \ 169 [.c find closest 20 29.9] [.c find closest 20 30.1] 170} "$x $y $y $x" 171test canvRect-6.3 {RectToPoint procedure} { 172 .c itemconfigure y -width 1 -outline black 173 list [.c find closest 14.4 28] [.c find closest 14.6 28] \ 174 [.c find closest 25.4 28] [.c find closest 25.6 28] 175} "$x $y $y $x" 176test canvRect-6.4 {RectToPoint procedure} { 177 .c itemconfigure y -width 1 -outline black 178 list [.c find closest 20 24.4] [.c find closest 20 24.6] \ 179 [.c find closest 20 30.4] [.c find closest 20 30.6] 180} "$x $y $y $x" 181.c itemconfigure x -fill {} -outline black -width 3 182.c itemconfigure y -outline {} 183test canvRect-6.5 {RectToPoint procedure} { 184 list [.c find closest 13.2 28] [.c find closest 13.3 28] \ 185 [.c find closest 26.7 28] [.c find closest 26.8 28] 186} "$x $y $y $x" 187test canvRect-6.6 {RectToPoint procedure} { 188 list [.c find closest 20 23.2] [.c find closest 20 23.3] \ 189 [.c find closest 20 31.7] [.c find closest 20 31.8] 190} "$x $y $y $x" 191.c delete withtag all 192set x [.c create rectangle 10 20 30 40 -outline {} -fill black] 193set y [.c create rectangle 40 40 50 50 -outline {} -fill black] 194test canvRect-6.7 {RectToPoint procedure} { 195 list [.c find closest 35 35] [.c find closest 36 36] \ 196 [.c find closest 37 37] [.c find closest 38 38] 197} "$x $y $y $y" 198 199.c delete withtag all 200set x [.c create rectangle 10 20 30 35 -fill green -outline {}] 201set y [.c create rectangle 40 45 60 70 -fill red -outline black -width 3] 202set z [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3] 203test canvRect-7.1 {RectToArea procedure} { 204 list [.c find overlapping 20 50 38 60] \ 205 [.c find overlapping 20 50 39 60] \ 206 [.c find overlapping 20 50 70 60] \ 207 [.c find overlapping 61 50 70 60] \ 208 [.c find overlapping 62 50 70 60] 209} "{} $y $y $y {}" 210test canvRect-7.2 {RectToArea procedure} { 211 list [.c find overlapping 45 20 55 43] \ 212 [.c find overlapping 45 20 55 44] \ 213 [.c find overlapping 45 20 55 80] \ 214 [.c find overlapping 45 71 55 80] \ 215 [.c find overlapping 45 72 55 80] 216} "{} $y $y $y {}" 217test canvRect-7.3 {RectToArea procedure} { 218 list [.c find overlapping 5 25 9.9 30] [.c find overlapping 5 25 10.1 30] 219} "{} $x" 220test canvRect-7.4 {RectToArea procedure} { 221 list [.c find overlapping 102 152 118 168] \ 222 [.c find overlapping 101 152 118 168] \ 223 [.c find overlapping 102 151 118 168] \ 224 [.c find overlapping 102 152 119 168] \ 225 [.c find overlapping 102 152 118 169] 226} "{} $z $z $z $z" 227test canvRect-7.5 {RectToArea procedure} { 228 list [.c find enclosed 20 40 38 80] \ 229 [.c find enclosed 20 40 39 80] \ 230 [.c find enclosed 20 40 70 80] \ 231 [.c find enclosed 61 40 70 80] \ 232 [.c find enclosed 62 40 70 80] 233} "{} {} $y {} {}" 234test canvRect-7.6 {RectToArea procedure} { 235 list [.c find enclosed 20 20 65 43] \ 236 [.c find enclosed 20 20 65 44] \ 237 [.c find enclosed 20 20 65 80] \ 238 [.c find enclosed 20 71 65 80] \ 239 [.c find enclosed 20 72 65 80] 240} "{} {} $y {} {}" 241 242.c delete withtag all 243set x [.c create oval 50 100 200 150 -fill green -outline {}] 244set y [.c create oval 50 100 200 150 -fill red -outline black -width 3] 245set z [.c create oval 50 100 200 150 -fill {} -outline black -width 3] 246test canvRect-8.1 {OvalToArea procedure} { 247 list [.c find overlapping 20 120 48 130] \ 248 [.c find overlapping 20 120 49 130] \ 249 [.c find overlapping 20 120 50.2 130] \ 250 [.c find overlapping 20 120 300 130] \ 251 [.c find overlapping 60 120 190 130] \ 252 [.c find overlapping 199.9 120 300 130] \ 253 [.c find overlapping 201 120 300 130] \ 254 [.c find overlapping 202 120 300 130] 255} "{} {$y $z} {$x $y $z} {$x $y $z} {$x $y} {$x $y $z} {$y $z} {}" 256test canvRect-8.2 {OvalToArea procedure} { 257 list [.c find overlapping 100 50 150 98] \ 258 [.c find overlapping 100 50 150 99] \ 259 [.c find overlapping 100 50 150 100.1] \ 260 [.c find overlapping 100 50 150 200] \ 261 [.c find overlapping 100 110 150 140] \ 262 [.c find overlapping 100 149.9 150 200] \ 263 [.c find overlapping 100 151 150 200] \ 264 [.c find overlapping 100 152 150 200] 265} "{} {$y $z} {$x $y $z} {$x $y $z} {$x $y} {$x $y $z} {$y $z} {}" 266test canvRect-8.3 {OvalToArea procedure} { 267 list [.c find overlapping 176 104 177 105] \ 268 [.c find overlapping 187 116 188 117] \ 269 [.c find overlapping 192 142 193 143] \ 270 [.c find overlapping 180 138 181 139] \ 271 [.c find overlapping 61 142 62 143] \ 272 [.c find overlapping 65 137 66 136] \ 273 [.c find overlapping 62 108 63 109] \ 274 [.c find overlapping 68 115 69 116] 275} "{} {$x $y} {} {$x $y} {} {$x $y} {} {$x $y}" 276 277test canvRect-9.1 {ScaleRectOval procedure} { 278 .c delete withtag all 279 .c create rect 100 300 200 350 -tags x 280 .c scale x 50 100 2 4 281 .c coords x 282} {150.0 900.0 350.0 1100.0} 283 284test canvRect-10.1 {TranslateRectOval procedure} { 285 .c delete withtag all 286 .c create rect 100 300 200 350 -tags x 287 .c move x 100 -10 288 .c coords x 289} {200.0 290.0 300.0 340.0} 290 291# This test is non-portable because different color information 292# will get generated on different displays (e.g. mono displays 293# vs. color). 294test canvRect-11.1 {RectOvalToPostscript procedure} {nonPortable macCrash} { 295 # Crashes on Mac because the XGetImage() call isn't implemented, causing a 296 # dereference of NULL. 297 298 .c configure -bd 0 -highlightthickness 0 299 .c delete withtag all 300 .c create rect 50 60 90 80 -fill black -stipple gray50 -outline {} 301 .c create oval 100 150 200 200 -fill {} -outline #ff0000 -width 5 302 update 303 set x [.c postscript] 304 string range $x [string first "-200 -150 translate" $x] end 305} {-200 -150 translate 3060 300 moveto 400 300 lineto 400 0 lineto 0 0 lineto closepath clip newpath 307gsave 30850 240 moveto 40 0 rlineto 0 -20 rlineto -40 0 rlineto closepath 3090.000 0.000 0.000 setrgbcolor AdjustColor 310clip 16 16 <5555aaaa5555aaaa5555aaaa5555aaaa5555aaaa5555aaaa5555aaaa5555 311aaaa> StippleFill 312grestore 313gsave 314matrix currentmatrix 315150 125 translate 50 25 scale 1 0 moveto 0 0 1 0 360 arc 316setmatrix 3175 setlinewidth 0 setlinejoin 2 setlinecap 3181.000 0.000 0.000 setrgbcolor AdjustColor 319stroke 320grestore 321restore showpage 322 323%%Trailer 324end 325%%EOF 326} 327 328# cleanup 329cleanupTests 330return 331