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