diff options
Diffstat (limited to 'tests/canvas.test')
| -rw-r--r-- | tests/canvas.test | 762 |
1 files changed, 173 insertions, 589 deletions
diff --git a/tests/canvas.test b/tests/canvas.test index 2b0da48..6fea894 100644 --- a/tests/canvas.test +++ b/tests/canvas.test @@ -1,213 +1,95 @@ -# 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. +# 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. -# Copyright (c) 2008 Donal K. Fellows # All rights reserved. package require tcltest 2.1 eval tcltest::configure $argv tcltest::loadTestedCommands -imageInit -# XXX - This test file is woefully incomplete. At present, only a few of the -# features are tested. +# XXX - This test file is woefully incomplete. At present, only a +# few of the features are tested. -# Canvas used in 1.* test cases canvas .c pack .c update - -test canvas-1.1 {configuration options: good value for "background"} -body { - .c configure -background #ff0000 - .c cget -background -} -result {#ff0000} -test canvas-1.2 {configuration options: bad value for "background"} -body { - .c configure -background non-existent -} -returnCodes error -result {unknown color name "non-existent"} -test canvas-1.3 {configuration options: good value for "bg"} -body { - .c configure -bg #ff0000 - .c cget -bg -} -result {#ff0000} -test canvas-1.4 {configuration options: bad value for "bg"} -body { - .c configure -bg non-existent -} -returnCodes error -result {unknown color name "non-existent"} -test canvas-1.5 {configuration options: good value for "bd"} -body { - .c configure -bd 4 - .c cget -bd -} -result {4} -test canvas-1.6 {configuration options: bad value for "bd"} -body { - .c configure -bd badValue -} -returnCodes error -result {bad screen distance "badValue"} -test canvas-1.7 {configuration options: good value for "borderwidth"} -body { - .c configure -borderwidth 1.3 - .c cget -borderwidth -} -result {1} -test canvas-1.8 {configuration options: bad value for "borderwidth"} -body { - .c configure -borderwidth badValue -} -returnCodes error -result {bad screen distance "badValue"} -test canvas-1.9 {configuration options: good value for "closeenough"} -body { - .c configure -closeenough 24 - .c cget -closeenough -} -result {24.0} -test canvas-1.10 {configuration options: bad value for "closeenough"} -body { - .c configure -closeenough bogus -} -returnCodes error -result {expected floating-point number but got "bogus"} -test canvas-1.11 {configuration options: good value for "confine"} -body { - .c configure -confine true - .c cget -confine -} -result {1} -test canvas-1.12 {configuration options: bad value for "confine"} -body { - .c configure -confine silly -} -returnCodes error -result {expected boolean value but got "silly"} -test canvas-1.13 {configuration options: good value for "cursor"} -body { - .c configure -cursor arrow - .c cget -cursor -} -result {arrow} -test canvas-1.14 {configuration options: bad value for "cursor"} -body { - .c configure -cursor badValue -} -returnCodes error -result {bad cursor spec "badValue"} -test canvas-1.15 {configuration options: good value for "height"} -body { - .c configure -height 2.1 - .c cget -height -} -result {2} -test canvas-1.16 {configuration options: bad value for "height"} -body { - .c configure -height x42 -} -returnCodes error -result {bad screen distance "x42"} -test canvas-1.17 {configuration options: good value for "highlightbackground"} -body { - .c configure -highlightbackground #112233 - .c cget -highlightbackground -} -result {#112233} -test canvas-1.18 {configuration options: bad value for "highlightbackground"} -body { - .c configure -highlightbackground ugly -} -returnCodes error -result {unknown color name "ugly"} -test canvas-1.19 {configuration options: good value for "highlightcolor"} -body { - .c configure -highlightcolor #110022 - .c cget -highlightcolor -} -result {#110022} -test canvas-1.20 {configuration options: bad value for "highlightcolor"} -body { - .c configure -highlightcolor bogus -} -returnCodes error -result {unknown color name "bogus"} -test canvas-1.21 {configuration options: good value for "highlightthickness"} -body { - .c configure -highlightthickness 18 - .c cget -highlightthickness -} -result {18} -test canvas-1.22 {configuration options: bad value for "highlightthickness"} -body { - .c configure -highlightthickness badValue -} -returnCodes error -result {bad screen distance "badValue"} -test canvas-1.23 {configuration options: good value for "insertbackground"} -body { - .c configure -insertbackground #110022 - .c cget -insertbackground -} -result {#110022} -test canvas-1.24 {configuration options: bad value for "insertbackground"} -body { - .c configure -insertbackground bogus -} -returnCodes error -result {unknown color name "bogus"} -test canvas-1.25 {configuration options: good value for "insertborderwidth"} -body { - .c configure -insertborderwidth 1.3 - .c cget -insertborderwidth -} -result {1} -test canvas-1.26 {configuration options: bad value for "insertborderwidth"} -body { - .c configure -insertborderwidth 2.6x -} -returnCodes error -result {bad screen distance "2.6x"} -test canvas-1.27 {configuration options: good value for "insertofftime"} -body { - .c configure -insertofftime 100 - .c cget -insertofftime -} -result {100} -test canvas-1.28 {configuration options: bad value for "insertofftime"} -body { - .c configure -insertofftime 3.2 -} -returnCodes error -result {expected integer but got "3.2"} -test canvas-1.29 {configuration options: good value for "insertontime"} -body { - .c configure -insertontime 100 - .c cget -insertontime -} -result {100} -test canvas-1.30 {configuration options: bad value for "insertontime"} -body { - .c configure -insertontime 3.2 -} -returnCodes error -result {expected integer but got "3.2"} -test canvas-1.31 {configuration options: good value for "insertwidth"} -body { - .c configure -insertwidth 1.3 - .c cget -insertwidth -} -result {1} -test canvas-1.32 {configuration options: bad value for "insertwidth"} -body { - .c configure -insertwidth 6x -} -returnCodes error -result {bad screen distance "6x"} -test canvas-1.33 {configuration options: good value for "relief"} -body { - .c configure -relief groove - .c cget -relief -} -result {groove} -test canvas-1.34 {configuration options: bad value for "relief"} -body { - .c configure -relief 1.5 -} -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} -test canvas-1.35 {configuration options: good value for "selectbackground"} -body { - .c configure -selectbackground #110022 - .c cget -selectbackground -} -result {#110022} -test canvas-1.36 {configuration options: bad value for "selectbackground"} -body { - .c configure -selectbackground bogus -} -returnCodes error -result {unknown color name "bogus"} -test canvas-1.37 {configuration options: good value for "selectborderwidth"} -body { - .c configure -selectborderwidth 1.3 - .c cget -selectborderwidth -} -result {1} -test canvas-1.38 {configuration options: bad value for "selectborderwidth"} -body { - .c configure -selectborderwidth badValue -} -returnCodes error -result {bad screen distance "badValue"} -test canvas-1.39 {configuration options: good value for "selectforeground"} -body { - .c configure -selectforeground #654321 - .c cget -selectforeground -} -result {#654321} -test canvas-1.40 {configuration options: bad value for "selectforeground"} -body { - .c configure -selectforeground bogus -} -returnCodes error -result {unknown color name "bogus"} -test canvas-1.41 {configuration options: good value for "takefocus"} -body { - .c configure -takefocus "any string" - .c cget -takefocus -} -result {any string} -test canvas-1.42 {configuration options: good value for "width"} -body { - .c configure -width 402 - .c cget -width -} -result {402} -test canvas-1.43 {configuration options: bad value for "width"} -body { - .c configure -width xyz -} -returnCodes error -result {bad screen distance "xyz"} -test canvas-1.44 {configuration options: good value for "xscrollcommand"} -body { - .c configure -xscrollcommand {Some command} - .c cget -xscrollcommand -} -result {Some command} -test canvas-1.45 {configuration options: good value for "yscrollcommand"} -body { - .c configure -yscrollcommand {Another command} - .c cget -yscrollcommand -} -result {Another command} -test canvas-1.46 {configure throws error on bad option} -body { - .c configure -gorp foo -} -returnCodes error -match glob -result {*} -test canvas-1.47 {configure throws error on bad option} -body { - catch {.c configure -gorp foo} +set i 1 +foreach {testname testinfo} { + canvas-1.1 {-background #ff0000 #ff0000 + non-existent {unknown color name "non-existent"}} + canvas-1.2 {-bg #ff0000 #ff0000 + non-existent {unknown color name "non-existent"}} + canvas-1.3 {-bd 4 4 badValue {bad screen distance "badValue"}} + canvas-1.4 {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} + canvas-1.5 {-closeenough 24 24.0 + bogus {expected floating-point number but got "bogus"}} + canvas-1.6 {-confine true 1 silly {expected boolean value but got "silly"}} + canvas-1.7 {-cursor arrow arrow badValue {bad cursor spec "badValue"}} + canvas-1.8 {-height 2.1 2 x42 {bad screen distance "x42"}} + canvas-1.9 {-highlightbackground #112233 #112233 + ugly {unknown color name "ugly"}} + canvas-1.10 {-highlightcolor #110022 #110022 + bogus {unknown color name "bogus"}} + canvas-1.11 {-highlightthickness 18 18 + badValue {bad screen distance "badValue"}} + canvas-1.12 {-insertbackground #110022 #110022 + bogus {unknown color name "bogus"}} + canvas-1.13 {-insertborderwidth 1.3 1 2.6x {bad screen distance "2.6x"}} + canvas-1.14 {-insertofftime 100 100 3.2 {expected integer but got "3.2"}} + canvas-1.15 {-insertontime 100 100 3.2 {expected integer but got "3.2"}} + canvas-1.16 {-insertwidth 1.3 1 6x {bad screen distance "6x"}} + canvas-1.17 {-relief groove groove + 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}} + canvas-1.18 {-selectbackground #110022 #110022 + bogus {unknown color name "bogus"}} + canvas-1.19 {-selectborderwidth 1.3 1 + badValue {bad screen distance "badValue"}} + canvas-1.20 {-selectforeground #654321 #654321 + bogus {unknown color name "bogus"}} + canvas-1.21 {-takefocus "any string" "any string" {} {}} + canvas-1.22 {-width 402 402 xyz {bad screen distance "xyz"}} + canvas-1.23 {-xscrollcommand {Some command} {Some command} {} {}} + canvas-1.24 {-yscrollcommand {Another command} {Another command} {} {}} +} { + lassign $testinfo name goodValue goodResult badValue badResult + test $testname-good "configuration options: good value for $name" { + .c configure $name $goodValue + lindex [.c configure $name] 4 + } $goodResult + incr i + if {$badValue ne ""} { + test $testname-bad "configuration options: bad value for $name" -body { + .c configure $name $badValue + } -returnCodes error -result $badResult + } + .c configure $name [lindex [.c configure $name] 3] + incr i +} +test canvas-1.25 {configure throws error on bad option} { + set res [list [catch {.c configure -gorp foo}]] .c create rect 10 10 100 100 - .c configure -gorp foo -} -returnCodes error -match glob -result {*} -catch {destroy .c} + lappend res [catch {.c configure -gorp foo}] + set res +} [list 1 1] -# Canvas used in 2.* test cases +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} -body { +test canvas-2.1 {CanvasWidgetCmd, bind option} { set i [.c create rect 10 10 100 100] - .c bind $i <a> -} -cleanup { - .c delete $i -} -returnCodes ok -test canvas-2.2 {CanvasWidgetCmd, bind option} -body { + list [catch {.c bind $i <a>} msg] $msg +} {0 {}} +test canvas-2.2 {CanvasWidgetCmd, bind option} { set i [.c create rect 10 10 100 100] - .c bind $i < -} -cleanup { - .c delete $i -} -returnCodes error -result {no event type or button # or keysym} -test canvas-2.3 {CanvasWidgetCmd, xview option} -body { + 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 @@ -215,10 +97,10 @@ test canvas-2.3 {CanvasWidgetCmd, xview option} -body { .c xview scroll 2 units update lappend x [.c xview] -} -result {{0.0 0.3} {0.4 0.7}} -test canvas-2.4 {CanvasWidgetCmd, xview option} -constraints nonPortable -body { - # This test gives slightly different results on platforms such as NetBSD. - # I don't know why... +} {{0.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 @@ -226,16 +108,14 @@ test canvas-2.4 {CanvasWidgetCmd, xview option} -constraints nonPortable -body { .c xview scroll 2 units update lappend x [.c xview] -} -result {{0.6 0.9} {0.66 0.96}} -catch {destroy .c} +} {{0.6 0.9} {0.66 0.96}} -# Canvas used in 3.* test cases +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} -body { +test canvas-3.1 {CanvasWidgetCmd, yview option} { .c configure -xscrollincrement 40 -yscrollincrement 5 .c yview moveto 0 update @@ -243,8 +123,8 @@ test canvas-3.1 {CanvasWidgetCmd, yview option} -body { .c yview scroll 3 units update lappend x [.c yview] -} -result {{0.0 0.5} {0.1875 0.6875}} -test canvas-3.2 {CanvasWidgetCmd, yview option} -body { +} {{0.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 @@ -252,43 +132,39 @@ test canvas-3.2 {CanvasWidgetCmd, yview option} -body { .c yview scroll 2 units update lappend x [.c yview] -} -result {{0.0 0.5} {0.1 0.6}} -destroy .c +} {{0.0 0.5} {0.1 0.6}} -test canvas-4.1 {ButtonEventProc procedure} -setup { +test canvas-4.1 {ButtonEventProc procedure} { deleteWindows - set x {} -} -body { 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 .] -} -result {.c1 #543210 {} {}} +} {.c1 #543210 {} {}} -test canvas-5.1 {ButtonCmdDeletedProc procedure} -body { +test canvas-5.1 {ButtonCmdDeletedProc procedure} { + deleteWindows canvas .c1 rename .c1 {} list [info command .c*] [winfo children .] -} -cleanup { - destroy .c1 -} -result {{} {}} +} {{} {}} -# Canvas used in 6.* test cases +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} -body { +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] -} -result {-205.0 -105.0} -test canvas-6.2 {CanvasSetOrigin procedure} -body { +} {-205.0 -105.0} +test canvas-6.2 {CanvasSetOrigin procedure} { .c configure -xscrollincrement 20 -yscrollincrement 10 set x "" foreach i {.08 .10 .48 .50} { @@ -296,9 +172,9 @@ test canvas-6.2 {CanvasSetOrigin procedure} -body { update lappend x [.c canvasx 0] } - return $x -} -result {-165.0 -145.0 35.0 55.0} -test canvas-6.3 {CanvasSetOrigin procedure} -body { + 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} { @@ -306,29 +182,30 @@ test canvas-6.3 {CanvasSetOrigin procedure} -body { update lappend x [.c canvasy 0] } - return $x -} -result {-95.0 -85.0 35.0 45.0} -test canvas-6.4 {CanvasSetOrigin procedure} -body { + 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 -} -result {215.0} -test canvas-6.5 {CanvasSetOrigin procedure} -body { +} {215.0} +test canvas-6.5 {CanvasSetOrigin procedure} { .c configure -xscrollincrement 20 -yscrollincrement 10 .c yview moveto 1.0 .c canvasy 0 -} -result {55.0} +} {55.0} + deleteWindows +set l [lsort [interp hidden]] test canvas-7.1 {canvas widget vs hidden commands} -setup { - canvas .c + catch {destroy .c} } -body { + canvas .c interp hide {} .c destroy .c list [winfo children .] [lsort [interp hidden]] -} -cleanup { - destroy .c -} -result [list {} [lsort [interp hidden]]] +} -result [list {} $l] test canvas-8.1 {canvas arc bbox} -setup { catch {destroy .c} @@ -347,10 +224,11 @@ test canvas-9.1 {canvas id creation and deletion} -setup { catch {destroy .c} canvas .c } -body { - # 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. + # 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 + 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} { @@ -360,8 +238,10 @@ test canvas-9.1 {canvas id creation and deletion} -setup { -anchor center -tags text } } - # The actual bench mark - this code also exercises all the hash table - # changes. + + # 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 @@ -371,13 +251,12 @@ test canvas-9.1 {canvas id creation and deletion} -setup { .c delete $id } }] 0] + set x "" } -result {} - test canvas-10.1 {find items using tag expressions} -setup { catch {destroy .c} canvas .c - set res {} } -body { .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] @@ -386,6 +265,7 @@ test canvas-10.1 {find items using tag expressions} -setup { .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}] @@ -406,7 +286,7 @@ test canvas-10.2 {check errors from tag expressions} -setup { .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] } -body { .c find withtag {&&c} -} -returnCodes error -result {unexpected operator in tag search expression} +} -returnCodes error -result {Unexpected operator in tag search expression} test canvas-10.3 {check errors from tag expressions} -setup { catch {destroy .c} canvas .c @@ -414,7 +294,7 @@ test canvas-10.3 {check errors from tag expressions} -setup { .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] } -body { .c find withtag {!!c} -} -returnCodes error -result {too many '!' in tag search expression} +} -returnCodes error -result {Too many '!' in tag search expression} test canvas-10.4 {check errors from tag expressions} -setup { catch {destroy .c} canvas .c @@ -422,7 +302,7 @@ test canvas-10.4 {check errors from tag expressions} -setup { .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] } -body { .c find withtag {b||} -} -returnCodes error -result {missing tag in tag search expression} +} -returnCodes error -result {Missing tag in tag search expression} test canvas-10.5 {check errors from tag expressions} -setup { catch {destroy .c} canvas .c @@ -430,7 +310,7 @@ test canvas-10.5 {check errors from tag expressions} -setup { .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] } -body { .c find withtag {b&&(c||)} -} -returnCodes error -result {unexpected operator in tag search expression} +} -returnCodes error -result {Unexpected operator in tag search expression} test canvas-10.6 {check errors from tag expressions} -setup { catch {destroy .c} canvas .c @@ -438,7 +318,7 @@ test canvas-10.6 {check errors from tag expressions} -setup { .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] } -body { .c find withtag {d&&""} -} -returnCodes error -result {null quoted tag string in tag search expression} +} -returnCodes error -result {Null quoted tag string in tag search expression} test canvas-10.7 {check errors from tag expressions} -setup { catch {destroy .c} canvas .c @@ -446,15 +326,15 @@ test canvas-10.7 {check errors from tag expressions} -setup { .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] } -body { .c find withtag "d&&\"tag with spaces" -} -returnCodes error -result {missing endquote in tag search expression} +} -returnCodes error -result {Missing endquote in tag search expression} test canvas-10.8 {check errors from tag expressions} -setup { 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"] -} -returnCodes error -body { +} -body { .c find withtag {a&&"tag with spaces"z} -} -result {invalid boolean operator in tag search expression} +} -returnCodes error -result {Invalid boolean operator in tag search expression} test canvas-10.9 {check errors from tag expressions} -setup { catch {destroy .c} canvas .c @@ -462,7 +342,7 @@ test canvas-10.9 {check errors from tag expressions} -setup { .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] } -body { .c find withtag {a&&b&c} -} -returnCodes error -result {singleton '&' in tag search expression} +} -returnCodes error -result {Singleton '&' in tag search expression} test canvas-10.10 {check errors from tag expressions} -setup { catch {destroy .c} canvas .c @@ -470,12 +350,11 @@ test canvas-10.10 {check errors from tag expressions} -setup { .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] } -body { .c find withtag {a||b|c} -} -returnCodes error -result {singleton '|' in tag search expression} +} -returnCodes error -result {Singleton '|' in tag search expression} test canvas-10.11 {backward compatility - strange tags that are not expressions} -setup { catch {destroy .c} canvas .c - .c create oval 20 20 40 40 -fill red \ - -tag [list { strange tag(xxx&yyy|zzz) " && \" || ! ^ " }] + .c create oval 20 20 40 40 -fill red -tag [list { strange tag(xxx&yyy|zzz) " && \" || ! ^ " }] } -body { .c find withtag { strange tag(xxx&yyy|zzz) " && \" || ! ^ " } } -result 1 @@ -507,22 +386,22 @@ test canvas-11.1 {canvas poly fill check, bug 5783} -setup { test canvas-11.2 {canvas poly overlap fill check, bug 226357} -setup { destroy .c pack [canvas .c] - set result {} } -body { + 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 + 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 + 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 + lappend result [.c find over 45 50 45 50]; # outside poly } -result {1 1 {} 1 {} 1 1 {} 1 {} 1} test canvas-11.3 {canvas poly dchars, bug 3291543} { # This would crash @@ -555,7 +434,6 @@ test canvas-12.2 {canvas mm obj, patch SF-403327, 102471} -setup { incr val } -result 12 -# procedure used in 13.1 test case proc kill_canvas {w} { destroy $w pack [canvas $w -height 200 -width 200] -fill both -expand yes @@ -565,9 +443,11 @@ proc kill_canvas {w} { $w bind blue <ButtonRelease-1> [subst { [lindex [info level 0] 0] $w append ::x ok - }] + } + ] } -test canvas-13.1 {canvas delete during event, SF bug-228024} -body { + +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 @@ -575,27 +455,27 @@ test canvas-13.1 {canvas delete during event, SF bug-228024} -body { event generate .c <1> -x 100 -y 100 event generate .c <ButtonRelease-1> -x 100 -y 100 } - return $::x -} -result {okokokokokokokokokokokokokokokokokokokokokokokokokokokokokok} + set ::x +} okokokokokokokokokokokokokokokokokokokokokokokokokokokokokok test canvas-14.1 {canvas scan SF bug 581560} -setup { destroy .c canvas .c -} -returnCodes error -body { +} -body { .c scan -} -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"} +} -returnCodes error -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"} test canvas-14.2 {canvas scan} -setup { destroy .c canvas .c -} -returnCodes error -body { +} -body { .c scan bogus -} -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"} +} -returnCodes error -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"} test canvas-14.3 {canvas scan} -setup { destroy .c canvas .c -} -returnCodes error -body { +} -body { .c scan mark -} -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"} +} -returnCodes error -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"} test canvas-14.4 {canvas scan} -setup { destroy .c canvas .c @@ -615,133 +495,37 @@ test canvas-14.6 {canvas scan} -setup { .c scan dragto 10 10 5 } -result {} -test canvas-15.1 {basic types check: arc requires coords} -setup { - destroy .c - canvas .c -} -returnCodes error -body { - .c create arc -} -result {wrong # args: should be ".c create arc coords ?arg ...?"} -test canvas-15.2 "basic coords check: arc coords are paired" -setup { - destroy .c - canvas .c -} -body { - .c create arc 0 -} -returnCodes error -result {wrong # coordinates: expected 4, got 1} -test canvas-15.3 {basic types check: bitmap requires coords} -setup { - destroy .c - canvas .c -} -returnCodes error -body { - .c create bitmap -} -result {wrong # args: should be ".c create bitmap coords ?arg ...?"} -test canvas-15.4 "basic coords check: bitmap coords are paired" -setup { - destroy .c - canvas .c -} -body { - .c create bitmap 0 -} -returnCodes error -result {wrong # coordinates: expected 2, got 1} -test canvas-15.5 {basic types check: image requires coords} -setup { - destroy .c - canvas .c -} -returnCodes error -body { - .c create image -} -result {wrong # args: should be ".c create image coords ?arg ...?"} -test canvas-15.6 "basic coords check: image coords are paired" -setup { - destroy .c - canvas .c -} -returnCodes error -body { - .c create image 0 -} -result {wrong # coordinates: expected 2, got 1} -test canvas-15.7 {basic types check: line requires coords} -setup { - destroy .c - canvas .c -} -returnCodes error -body { - .c create line -} -result {wrong # args: should be ".c create line coords ?arg ...?"} -test canvas-15.8 "basic coords check: line coords are paired" -setup { - destroy .c - canvas .c -} -returnCodes error -body { - .c create line 0 -} -result {wrong # coordinates: expected an even number, got 1} -test canvas-15.9 {basic types check: oval requires coords} -setup { - destroy .c - canvas .c -} -returnCodes error -body { - .c create oval -} -result {wrong # args: should be ".c create oval coords ?arg ...?"} -test canvas-15.10 "basic coords check: oval coords are paired" -setup { - destroy .c - canvas .c -} -returnCodes error -body { - .c create oval 0 -} -result {wrong # coordinates: expected 0 or 4, got 1} -test canvas-15.11 {basic types check: polygon requires coords} -setup { - destroy .c - canvas .c -} -returnCodes error -body { - .c create polygon -} -result {wrong # args: should be ".c create polygon coords ?arg ...?"} -test canvas-15.12 "basic coords check: polygon coords are paired" -setup { - destroy .c - canvas .c -} -returnCodes error -body { - .c create polygon 0 -} -result {wrong # coordinates: expected an even number, got 1} -test canvas-15.13 {basic types check: rect requires coords} -setup { - destroy .c - canvas .c -} -returnCodes error -body { - .c create rect -} -result {wrong # args: should be ".c create rect coords ?arg ...?"} -test canvas-15.14 "basic coords check: rect coords are paired" -setup { - destroy .c - canvas .c -} -returnCodes error -body { - .c create rect 0 -} -result {wrong # coordinates: expected 0 or 4, got 1} -test canvas-15.15 {basic types check: text requires coords} -setup { - destroy .c - canvas .c -} -returnCodes error -body { - .c create text -} -result {wrong # args: should be ".c create text coords ?arg ...?"} -test canvas-15.16 "basic coords check: text coords are paired" -setup { - destroy .c - canvas .c -} -returnCodes error -body { - .c create text 0 -} -result {wrong # coordinates: expected 2, got 1} -test canvas-15.17 {basic types check: window requires coords} -setup { - destroy .c - canvas .c -} -returnCodes error -body { - .c create window -} -result {wrong # args: should be ".c create window coords ?arg ...?"} -test canvas-15.18 "basic coords check: window coords are paired" -setup { - destroy .c - canvas .c -} -returnCodes error -body { - .c create window 0 -} -result {wrong # coordinates: expected 2, got 1} -test canvas-15.19 "basic coords check: centimeters are larger than pixels" -setup { - destroy .c - canvas .c -} -body { - set id [.c create rect 0 0 1cm 1cm] - expr {[lindex [.c coords $id] 2]>1} -} -result {1} -destroy .c +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} { + incr i + test canvas-15.$i "basic types check: $type requires coords" -setup { + destroy .c + canvas .c + } -body { + .c create $type + } -returnCodes error -result [format {wrong # args: should be ".c create %s coords ?arg arg ...?"} $type] + incr i + test canvas-15.$i "basic coords check: $type coords are paired" -setup { + destroy .c + canvas .c + } -match glob -body { + .c create $type 0 + } -returnCodes error -result "wrong # coordinates: expected*" +} test canvas-16.1 {arc coords check} -setup { + destroy .c canvas .c } -body { set id [.c create arc {0 10 20 30} -start 33] .c itemcget $id -start -} -cleanup { - destroy .c } -result {33.0} test canvas-17.1 {default smooth method handling} -setup { + destroy .c canvas .c } -body { set id [.c create line {0 0 1 1 2 2 3 3 4 4 5 5 6 6}] @@ -750,211 +534,11 @@ test canvas-17.1 {default smooth method handling} -setup { .c itemconfigure $id -smooth $smoother lappend result [.c itemcget $id -smooth] } - return $result -} -cleanup { - destroy .c + set result } -result {0 true true true raw raw true} -test canvas-18.1 {imove method - lines} -setup { - canvas .c -} -body { - set id [.c create line 0 0 1 1 2 2 3 3] - .c imove $id 0 4 4 - .c coords $id -} -cleanup { - destroy .c -} -result {4.0 4.0 1.0 1.0 2.0 2.0 3.0 3.0} -test canvas-18.2 {imove method - lines} -setup { - canvas .c -} -body { - set id [.c create line 0 0 1 1] - .c imove $id 0 4 4 - .c coords $id -} -cleanup { - destroy .c -} -result {4.0 4.0 1.0 1.0} -test canvas-18.3 {imove method - lines} -setup { - canvas .c -} -body { - set id [.c create line 0 0 1 1 2 2 3 3] - .c imove $id @1,1 4 4 - .c coords $id -} -cleanup { - destroy .c -} -result {0.0 0.0 4.0 4.0 2.0 2.0 3.0 3.0} -test canvas-18.4 {imove method - lines} -constraints knownBug -setup { - canvas .c -} -body { - set id [.c create line 0 0 1 1 2 2 3 3] - .c imove $id end 4 4 - .c coords $id -} -cleanup { - destroy .c -} -result {0.0 0.0 1.0 1.0 2.0 2.0 4.0 4.0} -test canvas-18.5 {imove method - polygon} -setup { - canvas .c -} -body { - set id [.c create polygon 0 0 1 1 2 2 3 3] - .c imove $id 0 4 4 - .c coords $id -} -cleanup { - destroy .c -} -result {4.0 4.0 1.0 1.0 2.0 2.0 3.0 3.0} -test canvas-18.6 {imove method - polygon} -setup { - canvas .c -} -body { - set id [.c create polygon 0 0 1 1] - .c imove $id 0 4 4 - .c coords $id -} -cleanup { - destroy .c -} -result {4.0 4.0 1.0 1.0} -test canvas-18.7 {imove method - polygon} -setup { - canvas .c -} -body { - set id [.c create polygon 0 0 1 1 2 2 3 3] - .c imove $id @1,1 4 4 - .c coords $id -} -cleanup { - destroy .c -} -result {0.0 0.0 4.0 4.0 2.0 2.0 3.0 3.0} -test canvas-18.8 {imove method - polygon} -constraints knownBug -setup { - canvas .c -} -body { - set id [.c create polygon 0 0 1 1 2 2 3 3] - .c imove $id end 4 4 - .c coords $id -} -cleanup { - destroy .c -} -result {0.0 0.0 1.0 1.0 2.0 2.0 4.0 4.0} -test canvas-18.9 {imove method - errors} -setup { - canvas .c -} -body { - set id [.c create line 0 0 1 1 2 2 3 3] - .c imove $id foobar 4 4 -} -cleanup { - destroy .c -} -returnCodes error -result {bad index "foobar"} -test canvas-18.10 {imove method - errors} -setup { - canvas .c -} -body { - set id [.c create line 0 0 1 1 2 2 3 3] - .c imove $id 0 foobar 4 -} -cleanup { - destroy .c -} -returnCodes error -result {bad screen distance "foobar"} -test canvas-18.11 {imove method - errors} -setup { - canvas .c -} -body { - set id [.c create line 0 0 1 1 2 2 3 3] - .c imove $id 0 4 foobar -} -cleanup { - destroy .c -} -returnCodes error -result {bad screen distance "foobar"} - -test canvas-19.1 {rchars method - lines} -setup { - canvas .c -} -body { - set id [.c create line 0 0 1 1 2 2 3 3] - .c rchars $id 2 4 {4 4} - .c coords $id -} -cleanup { - destroy .c -} -result {0.0 0.0 4.0 4.0 3.0 3.0} -test canvas-19.2 {rchars method - lines} -setup { - canvas .c -} -body { - set id [.c create line 0 0 1 1 2 2 3 3] - .c rchars $id 2 4 {} - .c coords $id -} -cleanup { - destroy .c -} -result {0.0 0.0 3.0 3.0} -test canvas-19.3 {rchars method - lines} -setup { - canvas .c -} -body { - set id [.c create line 0 0 1 1 2 2 3 3] - .c rchars $id 2 4 {10 11 12 13 14 15} - .c coords $id -} -cleanup { - destroy .c -} -result {0.0 0.0 10.0 11.0 12.0 13.0 14.0 15.0 3.0 3.0} -test canvas-19.4 {rchars method - polygon} -setup { - canvas .c -} -body { - set id [.c create polygon 0 0 1 1 2 2 3 3] - .c rchars $id 2 4 {4 4} - .c coords $id -} -cleanup { - destroy .c -} -result {0.0 0.0 4.0 4.0 3.0 3.0} -test canvas-19.5 {rchars method - polygon} -setup { - canvas .c -} -body { - set id [.c create polygon 0 0 1 1 2 2 3 3] - .c rchars $id 2 4 {} - .c coords $id -} -cleanup { - destroy .c -} -result {0.0 0.0 3.0 3.0} -test canvas-19.6 {rchars method - polygon} -setup { - canvas .c -} -body { - set id [.c create polygon 0 0 1 1 2 2 3 3] - .c rchars $id 2 4 {10 11 12 13 14 15} - .c coords $id -} -cleanup { - destroy .c -} -result {0.0 0.0 10.0 11.0 12.0 13.0 14.0 15.0 3.0 3.0} -test canvas-19.7 {rchars method - text} -setup { - canvas .c -} -body { - set id [.c create text 0 0 -text abcde] - .c rchars $id 1 3 XYZ - .c itemcget $id -text -} -cleanup { - destroy .c -} -result aXYZe -test canvas-19.8 {rchars method - text} -setup { - canvas .c -} -body { - set id [.c create text 0 0 -text abcde] - .c rchars $id 1 3 {} - .c itemcget $id -text -} -cleanup { - destroy .c -} -result ae -test canvas-19.9 {rchars method - text} -setup { - canvas .c -} -body { - set id [.c create text 0 0 -text abcde] - .c rchars $id 1 3 FOOBAR - .c itemcget $id -text -} -cleanup { - destroy .c -} -result aFOOBARe -test canvas-19.10 {rchars method - errors} -setup { - canvas .c -} -body { - set id [.c create line 0 0 1 1] - .c rchars $id foo 1 {2 2} -} -cleanup { - destroy .c -} -returnCodes error -result {bad index "foo"} -test canvas-19.11 {rchars method - errors} -setup { - canvas .c -} -body { - set id [.c create line 0 0 1 1] - .c rchars $id 1 foo {2 2} -} -cleanup { - destroy .c -} -returnCodes error -result {bad index "foo"} +destroy .c # cleanup -imageCleanup cleanupTests return - -# Local Variables: -# mode: tcl -# End: |