1# This file is a Tcl script to test out the procedures in tkCanvas.c, 2# which implements generic code for canvases. It is organized in the 3# standard fashion for Tcl tests. 4# 5# Copyright (c) 1995-1996 Sun Microsystems, Inc. 6# Copyright (c) 1998-2000 Ajuba Solutions. 7# All rights reserved. 8# 9# RCS: @(#) $Id: canvas.test,v 1.16 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 18# XXX - This test file is woefully incomplete. At present, only a 19# few of the features are tested. 20 21canvas .c 22pack .c 23update 24set i 1 25foreach test { 26 {-background #ff0000 #ff0000 non-existent 27 {unknown color name "non-existent"}} 28 {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}} 29 {-bd 4 4 badValue {bad screen distance "badValue"}} 30 {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} 31 {-closeenough 24 24.0 bogus {expected floating-point number but got "bogus"}} 32 {-confine true 1 silly {expected boolean value but got "silly"}} 33 {-cursor arrow arrow badValue {bad cursor spec "badValue"}} 34 {-height 2.1 2 x42 {bad screen distance "x42"}} 35 {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} 36 {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"}} 37 {-highlightthickness 18 18 badValue {bad screen distance "badValue"}} 38 {-insertbackground #110022 #110022 bogus {unknown color name "bogus"}} 39 {-insertborderwidth 1.3 1 2.6x {bad screen distance "2.6x"}} 40 {-insertofftime 100 100 3.2 {expected integer but got "3.2"}} 41 {-insertontime 100 100 3.2 {expected integer but got "3.2"}} 42 {-insertwidth 1.3 1 6x {bad screen distance "6x"}} 43 {-relief groove groove 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}} 44 {-selectbackground #110022 #110022 bogus {unknown color name "bogus"}} 45 {-selectborderwidth 1.3 1 badValue {bad screen distance "badValue"}} 46 {-selectforeground #654321 #654321 bogus {unknown color name "bogus"}} 47 {-takefocus "any string" "any string" {} {}} 48 {-width 402 402 xyz {bad screen distance "xyz"}} 49 {-xscrollcommand {Some command} {Some command} {} {}} 50 {-yscrollcommand {Another command} {Another command} {} {}} 51} { 52 set name [lindex $test 0] 53 test canvas-1.$i {configuration options} { 54 .c configure $name [lindex $test 1] 55 lindex [.c configure $name] 4 56 } [lindex $test 2] 57 incr i 58 if {[lindex $test 3] != ""} { 59 test canvas-1.$i {configuration options} { 60 list [catch {.c configure $name [lindex $test 3]} msg] $msg 61 } [list 1 [lindex $test 4]] 62 } 63 .c configure $name [lindex [.c configure $name] 3] 64 incr i 65} 66 67test canvas-1.40 {configure throws error on bad option} { 68 set res [list [catch {.c configure -gorp foo}]] 69 .c create rect 10 10 100 100 70 lappend res [catch {.c configure -gorp foo}] 71 set res 72} [list 1 1] 73 74 75catch {destroy .c} 76canvas .c -width 60 -height 40 -scrollregion {0 0 200 150} -bd 0 \ 77 -highlightthickness 0 78pack .c 79update 80 81test canvas-2.1 {CanvasWidgetCmd, bind option} { 82 set i [.c create rect 10 10 100 100] 83 list [catch {.c bind $i <a>} msg] $msg 84} {0 {}} 85test canvas-2.2 {CanvasWidgetCmd, bind option} { 86 set i [.c create rect 10 10 100 100] 87 list [catch {.c bind $i <} msg] $msg 88} {1 {no event type or button # or keysym}} 89test canvas-2.3 {CanvasWidgetCmd, xview option} { 90 .c configure -xscrollincrement 40 -yscrollincrement 5 91 .c xview moveto 0 92 update 93 set x [list [.c xview]] 94 .c xview scroll 2 units 95 update 96 lappend x [.c xview] 97} {{0 0.3} {0.4 0.7}} 98test canvas-2.4 {CanvasWidgetCmd, xview option} {nonPortable} { 99 # This test gives slightly different results on platforms such 100 # as NetBSD. I don't know why... 101 .c configure -xscrollincrement 0 -yscrollincrement 5 102 .c xview moveto 0.6 103 update 104 set x [list [.c xview]] 105 .c xview scroll 2 units 106 update 107 lappend x [.c xview] 108} {{0.6 0.9} {0.66 0.96}} 109 110catch {destroy .c} 111canvas .c -width 60 -height 40 -scrollregion {0 0 200 80} \ 112 -borderwidth 0 -highlightthickness 0 113pack .c 114update 115test canvas-3.1 {CanvasWidgetCmd, yview option} { 116 .c configure -xscrollincrement 40 -yscrollincrement 5 117 .c yview moveto 0 118 update 119 set x [list [.c yview]] 120 .c yview scroll 3 units 121 update 122 lappend x [.c yview] 123} {{0 0.5} {0.1875 0.6875}} 124test canvas-3.2 {CanvasWidgetCmd, yview option} { 125 .c configure -xscrollincrement 40 -yscrollincrement 0 126 .c yview moveto 0 127 update 128 set x [list [.c yview]] 129 .c yview scroll 2 units 130 update 131 lappend x [.c yview] 132} {{0 0.5} {0.1 0.6}} 133 134test canvas-4.1 {ButtonEventProc procedure} { 135 deleteWindows 136 canvas .c1 -bg #543210 137 rename .c1 .c2 138 set x {} 139 lappend x [winfo children .] 140 lappend x [.c2 cget -bg] 141 destroy .c1 142 lappend x [info command .c*] [winfo children .] 143} {.c1 #543210 {} {}} 144 145test canvas-5.1 {ButtonCmdDeletedProc procedure} { 146 deleteWindows 147 canvas .c1 148 rename .c1 {} 149 list [info command .c*] [winfo children .] 150} {{} {}} 151 152catch {destroy .c} 153canvas .c -width 100 -height 50 -scrollregion {-200 -100 305 102} \ 154 -borderwidth 2 -highlightthickness 3 155pack .c 156update 157test canvas-6.1 {CanvasSetOrigin procedure} { 158 .c configure -xscrollincrement 0 -yscrollincrement 0 159 .c xview moveto 0 160 .c yview moveto 0 161 update 162 list [.c canvasx 0] [.c canvasy 0] 163} {-205.0 -105.0} 164test canvas-6.2 {CanvasSetOrigin procedure} { 165 .c configure -xscrollincrement 20 -yscrollincrement 10 166 set x "" 167 foreach i {.08 .10 .48 .50} { 168 .c xview moveto $i 169 update 170 lappend x [.c canvasx 0] 171 } 172 set x 173} {-165.0 -145.0 35.0 55.0} 174test canvas-6.3 {CanvasSetOrigin procedure} { 175 .c configure -xscrollincrement 20 -yscrollincrement 10 176 set x "" 177 foreach i {.06 .08 .70 .72} { 178 .c yview moveto $i 179 update 180 lappend x [.c canvasy 0] 181 } 182 set x 183} {-95.0 -85.0 35.0 45.0} 184test canvas-6.4 {CanvasSetOrigin procedure} { 185 .c configure -xscrollincrement 20 -yscrollincrement 10 186 .c xview moveto 1.0 187 .c canvasx 0 188} {215.0} 189test canvas-6.5 {CanvasSetOrigin procedure} { 190 .c configure -xscrollincrement 20 -yscrollincrement 10 191 .c yview moveto 1.0 192 .c canvasy 0 193} {55.0} 194 195set l [interp hidden] 196deleteWindows 197 198test canvas-7.1 {canvas widget vs hidden commands} { 199 catch {destroy .c} 200 canvas .c 201 interp hide {} .c 202 destroy .c 203 list [winfo children .] [interp hidden] 204} [list {} $l] 205 206test canvas-8.1 {canvas arc bbox} { 207 catch {destroy .c} 208 canvas .c 209 .c create arc -100 10 100 210 -start 10 -extent 50 -style arc -tags arc1 210 set arcBox [.c bbox arc1] 211 .c create arc 100 10 300 210 -start 10 -extent 50 -style chord -tags arc2 212 set coordBox [.c bbox arc2] 213 .c create arc 300 10 500 210 -start 10 -extent 50 -style pieslice -tags arc3 214 set pieBox [.c bbox arc3] 215 list $arcBox $coordBox $pieBox 216} {{48 21 100 94} {248 21 300 94} {398 21 500 112}} 217test canvas-9.1 {canvas id creation and deletion} { 218 # With Tk 8.0.4 the ids are now stored in a hash table. You 219 # can use this test as a performance test with older versions 220 # by changing the value of size. 221 set size 15 222 223 catch {destroy .c} 224 set c [canvas .c] 225 for {set i 0} {$i < $size} {incr i} { 226 set x [expr {-10 + 3*$i}] 227 for {set j 0; set y -10} {$j < 10} {incr j; incr y 3} { 228 $c create rect ${x}c ${y}c [expr $x+2]c [expr $y+2]c \ 229 -outline black -fill blue -tags rect 230 $c create text [expr $x+1]c [expr $y+1]c -text "$i,$j" \ 231 -anchor center -tags text 232 } 233 } 234 235 # The actual bench mark - this code also exercises all the hash 236 # table changes. 237 238 set time [lindex [time { 239 foreach id [$c find withtag all] { 240 $c lower $id 241 $c raise $id 242 $c find withtag $id 243 $c bind <Return> $id {} 244 $c delete $id 245 } 246 }] 0] 247 248 set x "" 249} {} 250test canvas-10.1 {find items using tag expressions} { 251 catch {destroy .c} 252 canvas .c 253 .c create oval 20 20 40 40 -fill red -tag [list a b c d] 254 .c create oval 20 60 40 80 -fill yellow -tag [list b a] 255 .c create oval 20 100 40 120 -fill green -tag [list c b] 256 .c create oval 20 140 40 160 -fill blue -tag [list b] 257 .c create oval 20 180 40 200 -fill bisque -tag [list a d e] 258 .c create oval 20 220 40 240 -fill bisque -tag b 259 .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] 260 set res {} 261 lappend res [.c find withtag {!a}] 262 lappend res [.c find withtag {b&&c}] 263 lappend res [.c find withtag {b||c}] 264 lappend res [.c find withtag {a&&!b}] 265 lappend res [.c find withtag {!b&&!c}] 266 lappend res [.c find withtag {d&&a&&c&&b}] 267 lappend res [.c find withtag {b^a}] 268 lappend res [.c find withtag {(a&&!b)||(!a&&b)}] 269 lappend res [.c find withtag { ( a && ! b ) || ( ! a && b ) }] 270 lappend res [.c find withtag {a&&!(c||d)}] 271 lappend res [.c find withtag {d&&"tag with spaces"}] 272 lappend res [.c find withtag "tag with spaces"] 273} {{3 4 6 7} {1 3} {1 2 3 4 6} 5 {5 7} 1 {3 4 5 6} {3 4 5 6} {3 4 5 6} 2 7 7} 274test canvas-10.2 {check errors from tag expressions} { 275 catch {destroy .c} 276 canvas .c 277 .c create oval 20 20 40 40 -fill red -tag [list a b c d] 278 .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] 279 catch {.c find withtag {&&c}} err 280 set err 281} {Unexpected operator in tag search expression} 282test canvas-10.3 {check errors from tag expressions} { 283 catch {destroy .c} 284 canvas .c 285 .c create oval 20 20 40 40 -fill red -tag [list a b c d] 286 .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] 287 catch {.c find withtag {!!c}} err 288 set err 289} {Too many '!' in tag search expression} 290test canvas-10.4 {check errors from tag expressions} { 291 catch {destroy .c} 292 canvas .c 293 .c create oval 20 20 40 40 -fill red -tag [list a b c d] 294 .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] 295 catch {.c find withtag {b||}} err 296 set err 297} {Missing tag in tag search expression} 298test canvas-10.5 {check errors from tag expressions} { 299 catch {destroy .c} 300 canvas .c 301 .c create oval 20 20 40 40 -fill red -tag [list a b c d] 302 .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] 303 catch {.c find withtag {b&&(c||)}} err 304 set err 305} {Unexpected operator in tag search expression} 306test canvas-10.6 {check errors from tag expressions} { 307 catch {destroy .c} 308 canvas .c 309 .c create oval 20 20 40 40 -fill red -tag [list a b c d] 310 .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] 311 catch {.c find withtag {d&&""}} err 312 set err 313} {Null quoted tag string in tag search expression} 314test canvas-10.7 {check errors from tag expressions} { 315 catch {destroy .c} 316 canvas .c 317 .c create oval 20 20 40 40 -fill red -tag [list a b c d] 318 .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] 319 catch {.c find withtag "d&&\"tag with spaces"} err 320 set err 321} {Missing endquote in tag search expression} 322test canvas-10.8 {check errors from tag expressions} { 323 catch {destroy .c} 324 canvas .c 325 .c create oval 20 20 40 40 -fill red -tag [list a b c d] 326 .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] 327 catch {.c find withtag {a&&"tag with spaces"z}} err 328 set err 329} {Invalid boolean operator in tag search expression} 330test canvas-10.9 {check errors from tag expressions} { 331 catch {destroy .c} 332 canvas .c 333 .c create oval 20 20 40 40 -fill red -tag [list a b c d] 334 .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] 335 catch {.c find withtag {a&&b&c}} err 336 set err 337} {Singleton '&' in tag search expression} 338test canvas-10.10 {check errors from tag expressions} { 339 catch {destroy .c} 340 canvas .c 341 .c create oval 20 20 40 40 -fill red -tag [list a b c d] 342 .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] 343 catch {.c find withtag {a||b|c}} err 344 set err 345} {Singleton '|' in tag search expression} 346test canvas-10.11 {backward compatility - strange tags that are not expressions} { 347 catch {destroy .c} 348 canvas .c 349 .c create oval 20 20 40 40 -fill red -tag [list { strange tag(xxx&yyy|zzz) " && \" || ! ^ " }] 350 .c find withtag { strange tag(xxx&yyy|zzz) " && \" || ! ^ " } 351} {1} 352test canvas-10.12 {multple events bound to same tag expr} { 353 catch {destroy .c} 354 canvas .c 355 .c bind {a && b} <Enter> {puts Enter} 356 .c bind {a && b} <Leave> {puts Leave} 357} {} 358 359test canvas-11.1 {canvas poly fill check, bug 5783} { 360 # This would crash in 8.3.0 and 8.3.1 361 destroy .c 362 pack [canvas .c] 363 .c create polygon 0 0 100 100 200 50 \ 364 -fill {} -stipple gray50 -outline black 365} 1 366test canvas-11.2 {canvas poly overlap fill check, bug 226357} { 367 destroy .c 368 pack [canvas .c] 369 set result {} 370 .c create poly 30 30 90 90 30 90 90 30 371 lappend result [.c find over 40 40 45 45]; # rect region inc. edge 372 lappend result [.c find over 60 40 60 40]; # top-center point 373 lappend result [.c find over 0 0 0 0]; # not on poly 374 lappend result [.c find over 60 60 60 60]; # center-point 375 lappend result [.c find over 45 50 45 50]; # outside poly 376 .c itemconfig 1 -fill "" -outline black 377 lappend result [.c find over 40 40 45 45]; # rect region inc. edge 378 lappend result [.c find over 60 40 60 40]; # top-center point 379 lappend result [.c find over 0 0 0 0]; # not on poly 380 lappend result [.c find over 60 60 60 60]; # center-point 381 lappend result [.c find over 45 50 45 50]; # outside poly 382 .c itemconfig 1 -width 8 383 lappend result [.c find over 45 50 45 50]; # outside poly 384} {1 1 {} 1 {} 1 1 {} 1 {} 1} 385 386test canvas-12.1 {canvas mm obj, patch SF-403327, 102471} { 387 destroy .c 388 pack [canvas .c] 389 set qx [expr {1.+1.}] 390 # qx has type double and no string representation 391 .c scale all $qx 0 1. 1. 392 # qx has now type MMRep and no string representation 393 list $qx [string length $qx] 394} {2.0 3} 395test canvas-12.2 {canvas mm obj, patch SF-403327, 102471} { 396 destroy .c 397 pack [canvas .c] 398 set val 10 399 incr val 400 # qx has type double and no string representation 401 .c scale all $val 0 1 1 402 # qx has now type MMRep and no string representation 403 incr val 404} {12} 405 406proc kill_canvas {w} { 407 destroy $w 408 pack [canvas $w -height 200 -width 200] -fill both -expand yes 409 update idle 410 $w create rectangle 80 80 120 120 -fill blue -tags blue 411 # bind a button press to re-build the canvas 412 $w bind blue <ButtonRelease-1> [subst { 413 [lindex [info level 0] 0] $w 414 append ::x ok 415 } 416 ] 417} 418 419test canvas-13.1 {canvas delete during event, SF bug-228024} { 420 kill_canvas .c 421 set ::x {} 422 # do this many times to improve chances of triggering the crash 423 for {set i 0} {$i < 30} {incr i} { 424 event generate .c <1> -x 100 -y 100 425 event generate .c <ButtonRelease-1> -x 100 -y 100 426 } 427 set ::x 428} okokokokokokokokokokokokokokokokokokokokokokokokokokokokokok 429 430test canvas-14.1 {canvas scan SF bug 581560} { 431 destroy .c; canvas .c 432 list [catch {.c scan} msg] $msg 433} {1 {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"}} 434test canvas-14.2 {canvas scan} { 435 destroy .c; canvas .c 436 list [catch {.c scan bogus} msg] $msg 437} {1 {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"}} 438test canvas-14.3 {canvas scan} { 439 destroy .c; canvas .c 440 list [catch {.c scan mark} msg] $msg 441} {1 {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"}} 442test canvas-14.4 {canvas scan} { 443 destroy .c; canvas .c 444 list [catch {.c scan mark 10 10} msg] $msg 445} {0 {}} 446test canvas-14.5 {canvas scan} { 447 destroy .c; canvas .c 448 list [catch {.c scan mark 10 10 5} msg] $msg 449} {1 {wrong # args: should be ".c scan mark x y"}} 450test canvas-14.6 {canvas scan} { 451 destroy .c; canvas .c 452 list [catch {.c scan dragto 10 10 5} msg] $msg 453} {0 {}} 454 455set i 0 456proc create {w type args} { 457 eval [list $w create $type] $args 458} 459foreach type {arc bitmap image line oval polygon rect text window} { 460 test canvas-15.[incr i] "basic types check: $type" { 461 destroy .c; canvas .c 462 list [catch {.c create $type} msg] $msg 463 } [format {1 {wrong # args: should be ".c create %s coords ?arg arg ...?"}} $type] 464 test canvas-15.[incr i] "basic coords check: $type" { 465 destroy .c; canvas .c 466 list [catch {.c create $type 0} msg] \ 467 [string match "wrong # coordinates: expected*" $msg] 468 } {1 1} 469} 470 471test canvas-16.1 {arc coords check} { 472 destroy .c; canvas .c 473 set id [.c create arc {0 10 20 30} -start 33] 474 .c itemcget $id -start 475} {33.0} 476 477destroy .c 478 479# cleanup 480::tcltest::cleanupTests 481return 482