summaryrefslogtreecommitdiffstats
path: root/tests/canvas.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/canvas.test')
-rw-r--r--tests/canvas.test192
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]