diff options
Diffstat (limited to 'tests/canvas.test')
| -rw-r--r-- | tests/canvas.test | 192 |
1 files changed, 192 insertions, 0 deletions
diff --git a/tests/canvas.test b/tests/canvas.test new file mode 100644 index 0000000..786a29a --- /dev/null +++ b/tests/canvas.test @@ -0,0 +1,192 @@ +# 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. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) canvas.test 1.10 97/07/31 10:22:48 + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +# 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 +} + + +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, 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.2 {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} { + eval destroy [winfo children .] + 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} { + eval destroy [winfo children .] + 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] +eval destroy [winfo children .] + +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] |