Updated to tk 8.4.1

[pf3gnuchains/sourceware.git] / tk / tests / canvas.test

diff --git a/tk/tests/canvas.test b/tk/tests/canvas.test
index c4b7690..2cde224 100644 (file)
--- a/tk/tests/canvas.test
+++ b/tk/tests/canvas.test
@@ -8,15 +8,12 @@
 #
 # RCS: @(#) $Id$
 
-if {[lsearch [namespace children] ::tcltest] == -1} {
-    source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-foreach i [winfo children .] {
-    destroy $i
-}
-wm geometry . {}
-raise .
+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.
@@ -135,7 +132,7 @@ test canvas-3.2 {CanvasWidgetCmd, yview option} {
 } {{0 0.5} {0.1 0.6}}
 
 test canvas-4.1 {ButtonEventProc procedure} {
-    eval destroy [winfo children .]
+    deleteWindows
     canvas .c1 -bg #543210
     rename .c1 .c2
     set x {}
@@ -146,7 +143,7 @@ test canvas-4.1 {ButtonEventProc procedure} {
 } {.c1 #543210 {} {}}
 
 test canvas-5.1 {ButtonCmdDeletedProc procedure} {
-    eval destroy [winfo children .]
+    deleteWindows
     canvas .c1
     rename .c1 {}
     list [info command .c*] [winfo children .]
@@ -196,7 +193,7 @@ test canvas-6.5 {CanvasSetOrigin procedure} {
 } {55.0}
 
 set l [interp hidden]
-eval destroy [winfo children .]
+deleteWindows
 
 test canvas-7.1 {canvas widget vs hidden commands} {
     catch {destroy .c}
@@ -366,8 +363,97 @@ test canvas-11.1 {canvas poly fill check, bug 5783} {
     .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 <ButtonRelease-1> [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 <ButtonRelease-1> -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 {}}
+
+destroy .c
 
 # cleanup
 ::tcltest::cleanupTests
 return
-