# This file is a Tcl script to test out the procedures in tkCanvas.c, # which implements generic code for canvases. It is organized in the # standard fashion for Tcl tests. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 Ajuba Solutions. # All rights reserved. # # RCS: @(#) $Id: canvas.test,v 1.1.1.1 2007/07/10 15:05:18 duncan Exp $ package require tcltest 2.1 namespace import -force tcltest::configure namespace import -force tcltest::testsDirectory configure -testdir [file join [pwd] [file dirname [info script]]] configure -loadfile [file join [testsDirectory] constraints.tcl] tcltest::loadTestedCommands # XXX - This test file is woefully incomplete. At present, only a # few of the features are tested. canvas .c pack .c update set i 1 foreach test { {-background #ff0000 #ff0000 non-existent {unknown color name "non-existent"}} {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}} {-bd 4 4 badValue {bad screen distance "badValue"}} {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} {-closeenough 24 24.0 bogus {expected floating-point number but got "bogus"}} {-confine true 1 silly {expected boolean value but got "silly"}} {-cursor arrow arrow badValue {bad cursor spec "badValue"}} {-height 2.1 2 x42 {bad screen distance "x42"}} {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"}} {-highlightthickness 18 18 badValue {bad screen distance "badValue"}} {-insertbackground #110022 #110022 bogus {unknown color name "bogus"}} {-insertborderwidth 1.3 1 2.6x {bad screen distance "2.6x"}} {-insertofftime 100 100 3.2 {expected integer but got "3.2"}} {-insertontime 100 100 3.2 {expected integer but got "3.2"}} {-insertwidth 1.3 1 6x {bad screen distance "6x"}} {-relief groove groove 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}} {-selectbackground #110022 #110022 bogus {unknown color name "bogus"}} {-selectborderwidth 1.3 1 badValue {bad screen distance "badValue"}} {-selectforeground #654321 #654321 bogus {unknown color name "bogus"}} {-takefocus "any string" "any string" {} {}} {-width 402 402 xyz {bad screen distance "xyz"}} {-xscrollcommand {Some command} {Some command} {} {}} {-yscrollcommand {Another command} {Another command} {} {}} } { set name [lindex $test 0] test canvas-1.$i {configuration options} { .c configure $name [lindex $test 1] lindex [.c configure $name] 4 } [lindex $test 2] incr i if {[lindex $test 3] != ""} { test canvas-1.$i {configuration options} { list [catch {.c configure $name [lindex $test 3]} msg] $msg } [list 1 [lindex $test 4]] } .c configure $name [lindex [.c configure $name] 3] incr i } test canvas-1.40 {configure throws error on bad option} { set res [list [catch {.c configure -gorp foo}]] .c create rect 10 10 100 100 lappend res [catch {.c configure -gorp foo}] set res } [list 1 1] catch {destroy .c} canvas .c -width 60 -height 40 -scrollregion {0 0 200 150} -bd 0 \ -highlightthickness 0 pack .c update test canvas-2.1 {CanvasWidgetCmd, bind option} { set i [.c create rect 10 10 100 100] list [catch {.c bind $i } msg] $msg } {0 {}} test canvas-2.2 {CanvasWidgetCmd, bind option} { set i [.c create rect 10 10 100 100] list [catch {.c bind $i <} msg] $msg } {1 {no event type or button # or keysym}} test canvas-2.3 {CanvasWidgetCmd, xview option} { .c configure -xscrollincrement 40 -yscrollincrement 5 .c xview moveto 0 update set x [list [.c xview]] .c xview scroll 2 units update lappend x [.c xview] } {{0 0.3} {0.4 0.7}} test canvas-2.4 {CanvasWidgetCmd, xview option} {nonPortable} { # This test gives slightly different results on platforms such # as NetBSD. I don't know why... .c configure -xscrollincrement 0 -yscrollincrement 5 .c xview moveto 0.6 update set x [list [.c xview]] .c xview scroll 2 units update lappend x [.c xview] } {{0.6 0.9} {0.66 0.96}} catch {destroy .c} canvas .c -width 60 -height 40 -scrollregion {0 0 200 80} \ -borderwidth 0 -highlightthickness 0 pack .c update test canvas-3.1 {CanvasWidgetCmd, yview option} { .c configure -xscrollincrement 40 -yscrollincrement 5 .c yview moveto 0 update set x [list [.c yview]] .c yview scroll 3 units update lappend x [.c yview] } {{0 0.5} {0.1875 0.6875}} test canvas-3.2 {CanvasWidgetCmd, yview option} { .c configure -xscrollincrement 40 -yscrollincrement 0 .c yview moveto 0 update set x [list [.c yview]] .c yview scroll 2 units update lappend x [.c yview] } {{0 0.5} {0.1 0.6}} test canvas-4.1 {ButtonEventProc procedure} { deleteWindows canvas .c1 -bg #543210 rename .c1 .c2 set x {} lappend x [winfo children .] lappend x [.c2 cget -bg] destroy .c1 lappend x [info command .c*] [winfo children .] } {.c1 #543210 {} {}} test canvas-5.1 {ButtonCmdDeletedProc procedure} { deleteWindows canvas .c1 rename .c1 {} list [info command .c*] [winfo children .] } {{} {}} catch {destroy .c} canvas .c -width 100 -height 50 -scrollregion {-200 -100 305 102} \ -borderwidth 2 -highlightthickness 3 pack .c update test canvas-6.1 {CanvasSetOrigin procedure} { .c configure -xscrollincrement 0 -yscrollincrement 0 .c xview moveto 0 .c yview moveto 0 update list [.c canvasx 0] [.c canvasy 0] } {-205.0 -105.0} test canvas-6.2 {CanvasSetOrigin procedure} { .c configure -xscrollincrement 20 -yscrollincrement 10 set x "" foreach i {.08 .10 .48 .50} { .c xview moveto $i update lappend x [.c canvasx 0] } set x } {-165.0 -145.0 35.0 55.0} test canvas-6.3 {CanvasSetOrigin procedure} { .c configure -xscrollincrement 20 -yscrollincrement 10 set x "" foreach i {.06 .08 .70 .72} { .c yview moveto $i update lappend x [.c canvasy 0] } set x } {-95.0 -85.0 35.0 45.0} test canvas-6.4 {CanvasSetOrigin procedure} { .c configure -xscrollincrement 20 -yscrollincrement 10 .c xview moveto 1.0 .c canvasx 0 } {215.0} test canvas-6.5 {CanvasSetOrigin procedure} { .c configure -xscrollincrement 20 -yscrollincrement 10 .c yview moveto 1.0 .c canvasy 0 } {55.0} set l [interp hidden] deleteWindows test canvas-7.1 {canvas widget vs hidden commands} { catch {destroy .c} canvas .c interp hide {} .c destroy .c list [winfo children .] [interp hidden] } [list {} $l] test canvas-8.1 {canvas arc bbox} { catch {destroy .c} canvas .c .c create arc -100 10 100 210 -start 10 -extent 50 -style arc -tags arc1 set arcBox [.c bbox arc1] .c create arc 100 10 300 210 -start 10 -extent 50 -style chord -tags arc2 set coordBox [.c bbox arc2] .c create arc 300 10 500 210 -start 10 -extent 50 -style pieslice -tags arc3 set pieBox [.c bbox arc3] list $arcBox $coordBox $pieBox } {{48 21 100 94} {248 21 300 94} {398 21 500 112}} test canvas-9.1 {canvas id creation and deletion} { # With Tk 8.0.4 the ids are now stored in a hash table. You # can use this test as a performance test with older versions # by changing the value of size. set size 15 catch {destroy .c} set c [canvas .c] for {set i 0} {$i < $size} {incr i} { set x [expr {-10 + 3*$i}] for {set j 0; set y -10} {$j < 10} {incr j; incr y 3} { $c create rect ${x}c ${y}c [expr $x+2]c [expr $y+2]c \ -outline black -fill blue -tags rect $c create text [expr $x+1]c [expr $y+1]c -text "$i,$j" \ -anchor center -tags text } } # The actual bench mark - this code also exercises all the hash # table changes. set time [lindex [time { foreach id [$c find withtag all] { $c lower $id $c raise $id $c find withtag $id $c bind $id {} $c delete $id } }] 0] set x "" } {} test canvas-10.1 {find items using tag expressions} { catch {destroy .c} canvas .c .c create oval 20 20 40 40 -fill red -tag [list a b c d] .c create oval 20 60 40 80 -fill yellow -tag [list b a] .c create oval 20 100 40 120 -fill green -tag [list c b] .c create oval 20 140 40 160 -fill blue -tag [list b] .c create oval 20 180 40 200 -fill bisque -tag [list a d e] .c create oval 20 220 40 240 -fill bisque -tag b .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] set res {} lappend res [.c find withtag {!a}] lappend res [.c find withtag {b&&c}] lappend res [.c find withtag {b||c}] lappend res [.c find withtag {a&&!b}] lappend res [.c find withtag {!b&&!c}] lappend res [.c find withtag {d&&a&&c&&b}] lappend res [.c find withtag {b^a}] lappend res [.c find withtag {(a&&!b)||(!a&&b)}] lappend res [.c find withtag { ( a && ! b ) || ( ! a && b ) }] lappend res [.c find withtag {a&&!(c||d)}] lappend res [.c find withtag {d&&"tag with spaces"}] lappend res [.c find withtag "tag with spaces"] } {{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} test canvas-10.2 {check errors from tag expressions} { catch {destroy .c} canvas .c .c create oval 20 20 40 40 -fill red -tag [list a b c d] .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] catch {.c find withtag {&&c}} err set err } {Unexpected operator in tag search expression} test canvas-10.3 {check errors from tag expressions} { catch {destroy .c} canvas .c .c create oval 20 20 40 40 -fill red -tag [list a b c d] .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] catch {.c find withtag {!!c}} err set err } {Too many '!' in tag search expression} test canvas-10.4 {check errors from tag expressions} { catch {destroy .c} canvas .c .c create oval 20 20 40 40 -fill red -tag [list a b c d] .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] catch {.c find withtag {b||}} err set err } {Missing tag in tag search expression} test canvas-10.5 {check errors from tag expressions} { catch {destroy .c} canvas .c .c create oval 20 20 40 40 -fill red -tag [list a b c d] .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] catch {.c find withtag {b&&(c||)}} err set err } {Unexpected operator in tag search expression} test canvas-10.6 {check errors from tag expressions} { catch {destroy .c} canvas .c .c create oval 20 20 40 40 -fill red -tag [list a b c d] .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] catch {.c find withtag {d&&""}} err set err } {Null quoted tag string in tag search expression} test canvas-10.7 {check errors from tag expressions} { catch {destroy .c} canvas .c .c create oval 20 20 40 40 -fill red -tag [list a b c d] .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] catch {.c find withtag "d&&\"tag with spaces"} err set err } {Missing endquote in tag search expression} test canvas-10.8 {check errors from tag expressions} { catch {destroy .c} canvas .c .c create oval 20 20 40 40 -fill red -tag [list a b c d] .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] catch {.c find withtag {a&&"tag with spaces"z}} err set err } {Invalid boolean operator in tag search expression} test canvas-10.9 {check errors from tag expressions} { catch {destroy .c} canvas .c .c create oval 20 20 40 40 -fill red -tag [list a b c d] .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] catch {.c find withtag {a&&b&c}} err set err } {Singleton '&' in tag search expression} test canvas-10.10 {check errors from tag expressions} { catch {destroy .c} canvas .c .c create oval 20 20 40 40 -fill red -tag [list a b c d] .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] catch {.c find withtag {a||b|c}} err set err } {Singleton '|' in tag search expression} test canvas-10.11 {backward compatility - strange tags that are not expressions} { catch {destroy .c} canvas .c .c create oval 20 20 40 40 -fill red -tag [list { strange tag(xxx&yyy|zzz) " && \" || ! ^ " }] .c find withtag { strange tag(xxx&yyy|zzz) " && \" || ! ^ " } } {1} test canvas-10.12 {multple events bound to same tag expr} { catch {destroy .c} canvas .c .c bind {a && b} {puts Enter} .c bind {a && b} {puts Leave} } {} test canvas-11.1 {canvas poly fill check, bug 5783} { # This would crash in 8.3.0 and 8.3.1 destroy .c pack [canvas .c] .c create polygon 0 0 100 100 200 50 \ -fill {} -stipple gray50 -outline black } 1 test canvas-11.2 {canvas poly overlap fill check, bug 226357} { destroy .c pack [canvas .c] set result {} .c create poly 30 30 90 90 30 90 90 30 lappend result [.c find over 40 40 45 45]; # rect region inc. edge lappend result [.c find over 60 40 60 40]; # top-center point lappend result [.c find over 0 0 0 0]; # not on poly lappend result [.c find over 60 60 60 60]; # center-point lappend result [.c find over 45 50 45 50]; # outside poly .c itemconfig 1 -fill "" -outline black lappend result [.c find over 40 40 45 45]; # rect region inc. edge lappend result [.c find over 60 40 60 40]; # top-center point lappend result [.c find over 0 0 0 0]; # not on poly lappend result [.c find over 60 60 60 60]; # center-point lappend result [.c find over 45 50 45 50]; # outside poly .c itemconfig 1 -width 8 lappend result [.c find over 45 50 45 50]; # outside poly } {1 1 {} 1 {} 1 1 {} 1 {} 1} test canvas-12.1 {canvas mm obj, patch SF-403327, 102471} { destroy .c pack [canvas .c] set qx [expr {1.+1.}] # qx has type double and no string representation .c scale all $qx 0 1. 1. # qx has now type MMRep and no string representation list $qx [string length $qx] } {2.0 3} test canvas-12.2 {canvas mm obj, patch SF-403327, 102471} { destroy .c pack [canvas .c] set val 10 incr val # qx has type double and no string representation .c scale all $val 0 1 1 # qx has now type MMRep and no string representation incr val } {12} proc kill_canvas {w} { destroy $w pack [canvas $w -height 200 -width 200] -fill both -expand yes update idle $w create rectangle 80 80 120 120 -fill blue -tags blue # bind a button press to re-build the canvas $w bind blue [subst { [lindex [info level 0] 0] $w append ::x ok } ] } test canvas-13.1 {canvas delete during event, SF bug-228024} { kill_canvas .c set ::x {} # do this many times to improve chances of triggering the crash for {set i 0} {$i < 30} {incr i} { event generate .c <1> -x 100 -y 100 event generate .c -x 100 -y 100 } set ::x } okokokokokokokokokokokokokokokokokokokokokokokokokokokokokok test canvas-14.1 {canvas scan SF bug 581560} { destroy .c; canvas .c list [catch {.c scan} msg] $msg } {1 {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"}} test canvas-14.2 {canvas scan} { destroy .c; canvas .c list [catch {.c scan bogus} msg] $msg } {1 {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"}} test canvas-14.3 {canvas scan} { destroy .c; canvas .c list [catch {.c scan mark} msg] $msg } {1 {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"}} test canvas-14.4 {canvas scan} { destroy .c; canvas .c list [catch {.c scan mark 10 10} msg] $msg } {0 {}} test canvas-14.5 {canvas scan} { destroy .c; canvas .c list [catch {.c scan mark 10 10 5} msg] $msg } {1 {wrong # args: should be ".c scan mark x y"}} test canvas-14.6 {canvas scan} { destroy .c; canvas .c list [catch {.c scan dragto 10 10 5} msg] $msg } {0 {}} set i 0 proc create {w type args} { eval [list $w create $type] $args } foreach type {arc bitmap image line oval polygon rect text window} { test canvas-15.[incr i] "basic types check: $type" { destroy .c; canvas .c list [catch {.c create $type} msg] $msg } [format {1 {wrong # args: should be ".c create %s coords ?arg arg ...?"}} $type] test canvas-15.[incr i] "basic coords check: $type" { destroy .c; canvas .c list [catch {.c create $type 0} msg] \ [string match "wrong # coordinates: expected*" $msg] } {1 1} } test canvas-16.1 {arc coords check} { destroy .c; canvas .c set id [.c create arc {0 10 20 30} -start 33] .c itemcget $id -start } {33.0} destroy .c # cleanup ::tcltest::cleanupTests return