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