summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authoraniap <aniap>2008-08-11 21:33:17 (GMT)
committeraniap <aniap>2008-08-11 21:33:17 (GMT)
commita66a478b11a3a5fb8ca2f96b1455d1513f6b228e (patch)
treea599278039a0e8e4f1e616c3919ec81896ed19a1
parent3e1853a0a7548512056eb08a8b4916ec2f683ee6 (diff)
downloadtk-a66a478b11a3a5fb8ca2f96b1455d1513f6b228e.zip
tk-a66a478b11a3a5fb8ca2f96b1455d1513f6b228e.tar.gz
tk-a66a478b11a3a5fb8ca2f96b1455d1513f6b228e.tar.bz2
Update to tcltest2
-rw-r--r--ChangeLog10
-rw-r--r--tests/canvImg.test797
-rw-r--r--tests/canvRect.test597
-rw-r--r--tests/canvText.test884
-rw-r--r--tests/obj.test24
5 files changed, 1625 insertions, 687 deletions
diff --git a/ChangeLog b/ChangeLog
index f014bf1..ada18cd 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,11 +1,15 @@
-2008-08-07 Ania Pawelczyk <aniap@users.sourceforge.net>
+2008-08-11 Ania Pawelczyk <aniap@users.sourceforge.net>
- * test/canvas.test: Update to tcltest2
+ * test/canvImg.test: Update to tcltest2
+ * test/canvRect.test
+ * test/canvText.test
+ * test/obj.test
2008-08-07 Ania Pawelczyk <aniap@users.sourceforge.net>
* test/canvPs.test: Update to tcltest2
- * test/config.test
+ * test/config.test
+ * test/canvas.test
2008-08-05 Joe English <jenglish@users.sourceforge.net>
diff --git a/tests/canvImg.test b/tests/canvImg.test
index 7814d8a..94f818a 100644
--- a/tests/canvImg.test
+++ b/tests/canvImg.test
@@ -7,105 +7,163 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: canvImg.test,v 1.9 2007/05/16 18:10:35 dgp Exp $
+# RCS: @(#) $Id: canvImg.test,v 1.10 2008/08/11 21:33:17 aniap Exp $
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
eval image delete [image names]
+# Canvas used in every test case of the whole file
canvas .c
pack .c
update
-if {[testConstraint testImageType]} {
- image create test foo -variable x
- image create test foo2 -variable y
- foo2 changed 0 0 0 0 80 60
-}
-test canvImg-1.1 {options for image items} {
- .c delete all
+
+
+test canvImg-1.1 {options for image items} -body {
.c create image 50 50 -anchor nw -tags i1
.c itemconfigure i1 -anchor
-} {-anchor {} {} center nw}
-test canvImg-1.2 {options for image items} {
- .c delete all
- list [catch {.c create image 50 50 -anchor gorp -tags i1} msg] $msg
-} {1 {bad anchor position "gorp": must be n, ne, e, se, s, sw, w, nw, or center}}
-test canvImg-1.3 {options for image items} testImageType {
- .c delete all
+} -cleanup {
+ .c delete all
+} -result {-anchor {} {} center nw}
+test canvImg-1.2 {options for image items} -body {
+ .c create image 50 50 -anchor gorp -tags i1
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {bad anchor position "gorp": must be n, ne, e, se, s, sw, w, nw, or center}
+test canvImg-1.3 {options for image items} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
.c create image 50 50 -image foo -tags i1
.c itemconfigure i1 -image
-} {-image {} {} {} foo}
-test canvImg-1.4 {options for image items} {
- .c delete all
- list [catch {.c create image 50 50 -image unknown -tags i1} msg] $msg
-} {1 {image "unknown" doesn't exist}}
-test canvImg-1.5 {options for image items} testImageType {
- .c delete all
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {-image {} {} {} foo}
+test canvImg-1.4 {options for image items} -body {
+ .c create image 50 50 -image unknown -tags i1
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {image "unknown" doesn't exist}
+test canvImg-1.5 {options for image items} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
.c create image 50 50 -image foo -tags {i1 foo}
.c itemconfigure i1 -tags
-} {-tags {} {} {} {i1 foo}}
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {-tags {} {} {} {i1 foo}}
-test canvImg-2.1 {CreateImage procedure} {
- list [catch {.c create image 40} msg] $msg
-} {1 {wrong # coordinates: expected 2, got 1}}
-test canvImg-2.2 {CreateImage procedure} {
- list [catch {.c create image 40 50 60} msg] $msg
-} {1 {unknown option "60"}}
-test canvImg-2.3 {CreateImage procedure} {
+test canvImg-2.1 {CreateImage procedure} -body {
+ .c create image 40
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {wrong # coordinates: expected 2, got 1}
+test canvImg-2.2 {CreateImage procedure} -body {
+ .c create image 40 50 60
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {unknown option "60"}
+test canvImg-2.3 {CreateImage procedure} -body {
.c delete all
set i [.c create image 50 50]
list [lindex [.c itemconf $i -anchor] 4] \
[lindex [.c itemconf $i -image] 4] \
[lindex [.c itemconf $i -tags] 4]
-} {center {} {}}
-test canvImg-2.4 {CreateImage procedure} {
- list [catch {.c create image xyz 40} msg] $msg
-} {1 {bad screen distance "xyz"}}
-test canvImg-2.5 {CreateImage procedure} {
- list [catch {.c create image 50 qrs} msg] $msg
-} {1 {bad screen distance "qrs"}}
-test canvImg-2.6 {CreateImage procedure} testImageType {
- list [catch {.c create image 50 50 -gorp foo} msg] $msg
-} {1 {unknown option "-gorp"}}
-
-test canvImg-3.1 {ImageCoords procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {center {} {}}
+test canvImg-2.4 {CreateImage procedure} -body {
+ .c create image xyz 40
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {bad screen distance "xyz"}
+test canvImg-2.5 {CreateImage procedure} -body {
+ .c create image 50 qrs
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {bad screen distance "qrs"}
+test canvImg-2.6 {CreateImage procedure} -constraints testImageType -body {
+ .c create image 50 50 -gorp foo
+} -cleanup {
.c delete all
+} -returnCodes {error} -result {unknown option "-gorp"}
+
+
+test canvImg-3.1 {ImageCoords procedure} -constraints testImageType -setup {
+ image create test foo
+} -body {
.c create image 50 100 -image foo -tags i1
.c coords i1
-} {50.0 100.0}
-test canvImg-3.2 {ImageCoords procedure} testImageType {
- .c delete all
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {50.0 100.0}
+test canvImg-3.2 {ImageCoords procedure} -constraints testImageType -setup {
+ image create test foo
+} -body {
.c create image 50 100 -image foo -tags i1
- list [catch {.c coords i1 dumb 100} msg] $msg
-} {1 {bad screen distance "dumb"}}
-test canvImg-3.3 {ImageCoords procedure} testImageType {
+ .c coords i1 dumb 100
+} -cleanup {
+ .c delete all
+ image delete foo
+} -returnCodes {error} -result {bad screen distance "dumb"}
+test canvImg-3.3 {ImageCoords procedure} -constraints testImageType -setup {
+ image create test foo
+} -body {
.c delete all
.c create image 50 100 -image foo -tags i1
- list [catch {.c coords i1 250 dumb0} msg] $msg
-} {1 {bad screen distance "dumb0"}}
-test canvImg-3.4 {ImageCoords procedure} testImageType {
+ .c coords i1 250 dumb0
+} -cleanup {
+ .c delete all
+ image delete foo
+} -returnCodes {error} -result {bad screen distance "dumb0"}
+test canvImg-3.4 {ImageCoords procedure} -constraints testImageType -setup {
+ image create test foo
+} -body {
.c delete all
.c create image 50 100 -image foo -tags i1
- list [catch {.c coords i1 250} msg] $msg
-} {1 {wrong # coordinates: expected 2, got 1}}
-test canvImg-3.5 {ImageCoords procedure} testImageType {
+ .c coords i1 250
+} -cleanup {
+ .c delete all
+ image delete foo
+} -returnCodes {error} -result {wrong # coordinates: expected 2, got 1}
+test canvImg-3.5 {ImageCoords procedure} -constraints testImageType -setup {
+ image create test foo
+} -body {
.c delete all
.c create image 50 100 -image foo -tags i1
- list [catch {.c coords i1 250 300 400} msg] $msg
-} {1 {wrong # coordinates: expected 0 or 2, got 3}}
+ .c coords i1 250 300 400
+} -cleanup {
+ .c delete all
+ image delete foo
+} -returnCodes {error} -result {wrong # coordinates: expected 0 or 2, got 3}
-test canvImg-4.1 {ConfiugreImage procedure} testImageType {
+
+test canvImg-4.1 {ConfiugreImage procedure} -constraints testImageType -setup {
.c delete all
+} -body {
+ image create test foo -variable x
.c create image 50 100 -image foo -tags i1
update
set x {}
.c itemconfigure i1 -image {}
update
list $x [.c bbox i1]
-} {{{foo free}} {}}
-test canvImg-4.2 {ConfiugreImage procedure} testImageType {
- .c delete all
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {{{foo free}} {}}
+test canvImg-4.2 {ConfiugreImage procedure} -constraints testImageType -setup {
+ .c delete all
+} -body {
+ image create test foo -variable x
+ image create test foo2 -variable y
+ foo2 changed 0 0 0 0 80 60
.c create image 50 100 -image foo -tags i1 -anchor nw
update
set x {}
@@ -113,19 +171,34 @@ test canvImg-4.2 {ConfiugreImage procedure} testImageType {
.c itemconfigure i1 -image foo2
update
list $x $y [.c bbox i1]
-} {{{foo free}} {{foo2 get} {foo2 display 0 0 80 60 30 30}} {50 100 130 160}}
-test canvImg-4.3 {ConfiugreImage procedure} testImageType {
- .c delete all
+} -cleanup {
+ .c delete all
+ image delete foo
+ image delete foo2
+} -result {{{foo free}} {{foo2 get} {foo2 display 0 0 80 60 30 30}} {50 100 130 160}}
+test canvImg-4.3 {ConfiugreImage procedure} -constraints testImageType -setup {
+ .c delete all
+} -body {
+ image create test foo -variable x
+ image create test foo2 -variable y
+ foo2 changed 0 0 0 0 80 60
.c create image 50 100 -image foo -tags i1 -anchor nw
update
set x {}
set y {}
- list [catch {.c itemconfigure i1 -image lousy} msg] $msg
-} {1 {image "lousy" doesn't exist}}
+ .c itemconfigure i1 -image lousy
+} -cleanup {
+ .c delete all
+ image delete foo foo2
+} -returnCodes {error} -result {image "lousy" doesn't exist}
-test canvImg-5.1 {DeleteImage procedure} testImageType {
- image create test xyzzy -variable z
+
+test canvImg-5.1 {DeleteImage procedure} -constraints testImageType -setup {
.c delete all
+} -body {
+ image create test foo -variable x
+ image create test foo2 -variable y
+ image create test xyzzy -variable z
.c create image 50 100 -image xyzzy -tags i1
update
set names [lsort [image names]]
@@ -135,259 +208,587 @@ test canvImg-5.1 {DeleteImage procedure} testImageType {
.c delete i1
update
list $names $names2 $z [lsort [image names]]
-} {{foo foo2 xyzzy} {foo foo2} {} {foo foo2}}
-test canvImg-5.2 {DeleteImage procedure (don't delete non-existent image)} {
+} -cleanup {
+ image delete foo foo2
+ .c delete all
+} -result {{foo foo2 xyzzy} {foo foo2} {} {foo foo2}}
+test canvImg-5.2 {DeleteImage procedure (don't delete non-existent image)} -body {
.c delete all
.c create image 50 100 -tags i1
update
.c delete i1
update
-} {}
+} -result {}
+
-test canvImg-6.1 {ComputeImageBbox procedure} testImageType {
+test canvImg-6.1 {ComputeImageBbox procedure} -constraints testImageType -setup {
+ image create test foo
.c delete all
+} -body {
.c create image 15.51 17.51 -image foo -tags i1 -anchor nw
.c bbox i1
-} {16 18 46 33}
-test canvImg-6.2 {ComputeImageBbox procedure} testImageType {
+} -cleanup {
.c delete all
+ image delete foo
+} -result {16 18 46 33}
+test canvImg-6.2 {ComputeImageBbox procedure} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
.c create image 15.49 17.49 -image foo -tags i1 -anchor nw
.c bbox i1
-} {15 17 45 32}
-test canvImg-6.3 {ComputeImageBbox procedure} {
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {15 17 45 32}
+test canvImg-6.3 {ComputeImageBbox procedure} -setup {
.c delete all
+} -body {
.c create image 20 30 -tags i1 -anchor nw
.c bbox i1
-} {}
-test canvImg-6.4 {ComputeImageBbox procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-6.4 {ComputeImageBbox procedure} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor nw
.c bbox i1
-} {20 30 50 45}
-test canvImg-6.5 {ComputeImageBbox procedure} testImageType {
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {20 30 50 45}
+test canvImg-6.5 {ComputeImageBbox procedure} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor n
.c bbox i1
-} {5 30 35 45}
-test canvImg-6.6 {ComputeImageBbox procedure} testImageType {
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {5 30 35 45}
+test canvImg-6.6 {ComputeImageBbox procedure} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor ne
.c bbox i1
-} {-10 30 20 45}
-test canvImg-6.7 {ComputeImageBbox procedure} testImageType {
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {-10 30 20 45}
+test canvImg-6.7 {ComputeImageBbox procedure} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor e
.c bbox i1
-} {-10 23 20 38}
-test canvImg-6.8 {ComputeImageBbox procedure} testImageType {
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {-10 23 20 38}
+test canvImg-6.8 {ComputeImageBbox procedure} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor se
.c bbox i1
-} {-10 15 20 30}
-test canvImg-6.9 {ComputeImageBbox procedure} testImageType {
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {-10 15 20 30}
+test canvImg-6.9 {ComputeImageBbox procedure} -constraints testImageType -setup {
+ image create test foo
+ .c delete all
+} -body {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor s
.c bbox i1
-} {5 15 35 30}
-test canvImg-6.10 {ComputeImageBbox procedure} testImageType {
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {5 15 35 30}
+test canvImg-6.10 {ComputeImageBbox procedure} -constraints {
+ testImageType
+} -setup {
+ image create test foo
+ .c delete all
+} -body {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor sw
.c bbox i1
-} {20 15 50 30}
-test canvImg-6.11 {ComputeImageBbox procedure} testImageType {
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {20 15 50 30}
+test canvImg-6.11 {ComputeImageBbox procedure} -constraints {
+ testImageType
+} -setup {
+ image create test foo
+ .c delete all
+} -body {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor w
.c bbox i1
-} {20 23 50 38}
-test canvImg-6.12 {ComputeImageBbox procedure} testImageType {
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {20 23 50 38}
+test canvImg-6.12 {ComputeImageBbox procedure} -constraints {
+ testImageType
+} -setup {
+ image create test foo
+ .c delete all
+} -body {
.c delete all
.c create image 20 30 -image foo -tags i1 -anchor center
.c bbox i1
-} {5 23 35 38}
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {5 23 35 38}
# The following test is non-portable because of differences in
# coordinate rounding on some machines (does 0.5 round up?).
-test canvImg-7.1 {DisplayImage procedure} {nonPortable testImageType} {
+test canvImg-7.1 {DisplayImage procedure} -constraints {
+ nonPortable testImageType
+} -setup {
.c delete all
+} -body {
+ image create test foo -variable x
.c create image 50 100 -image foo -tags i1 -anchor nw
update
set x {}
.c create rect 55 110 65 115 -width 1 -outline black -fill white
update
set x
-} {{foo display 4 9 12 6 30 30}}
-test canvImg-7.2 {DisplayImage procedure, no image} {
+} -result {{foo display 4 9 12 6 30 30}}
+test canvImg-7.2 {DisplayImage procedure, no image} -body {
.c delete all
.c create image 50 100 -tags i1
update
.c create rect 55 110 65 115 -width 1 -outline black -fill white
update
-} {}
+} -result {}
-.c delete all
+
+# image used in 8.* test cases
if {[testConstraint testImageType]} {
- .c create image 50 100 -image foo -tags image -anchor nw
-}
-.c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
-foreach check {
- {canvImg-8.1 {50 70 80 81} {70 90} rect}
- {canvImg-8.2 {50 70 80 79} {70 90} image}
- {canvImg-8.3 {99 70 110 81} {90 90} rect}
- {canvImg-8.4 {101 70 110 79} {90 90} image}
- {canvImg-8.5 {99 100 110 115} {90 110} rect}
- {canvImg-8.6 {101 100 110 115} {90 110} image}
- {canvImg-8.7 {99 134 110 145} {90 125} rect}
- {canvImg-8.8 {101 136 110 145} {90 125} image}
- {canvImg-8.9 {50 134 80 145} {70 125} rect}
- {canvImg-8.10 {50 136 80 145} {70 125} image}
- {canvImg-8.11 {20 134 31 145} {40 125} rect}
- {canvImg-8.12 {20 136 29 145} {40 125} image}
- {canvImg-8.13 {20 100 31 115} {40 110} rect}
- {canvImg-8.14 {20 100 29 115} {40 110} image}
- {canvImg-8.15 {20 70 31 80} {40 90} rect}
- {canvImg-8.16 {20 70 29 79} {40 90} image}
- {canvImg-8.17 {60 70 69 109} {70 110} image}
- {canvImg-8.18 {60 70 71 111} {70 110} rect}
-} {
- lassign $check name rectCoords testPoint result
- test $name {ImageToPoint procedure} testImageType {
- .c coords rect {*}$rectCoords
- .c gettags [.c find closest {*}$testPoint]
- } $result
+ image create test foo
}
-
+test canvImg-8.1 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect 50 70 80 81
+ .c gettags [.c find closest 70 90]
+} -cleanup {
+ .c delete all
+} -result {rect}
+test canvImg-8.2 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{50 70 80 79}
+ .c gettags [.c find closest {*}{70 90}]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.3 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{99 70 110 81}
+ .c gettags [.c find closest {*}{90 90}]
+} -cleanup {
+ .c delete all
+} -result {rect}
+test canvImg-8.4 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{101 70 110 79}
+ .c gettags [.c find closest {*}{90 90}]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.5 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{99 100 110 115}
+ .c gettags [.c find closest {*}{90 110}]
+} -cleanup {
+ .c delete all
+} -result {rect}
+test canvImg-8.6 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{101 100 110 115}
+ .c gettags [.c find closest {*}{90 110}]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.7 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{99 134 110 145}
+ .c gettags [.c find closest {*}{90 125}]
+} -cleanup {
+ .c delete all
+} -result {rect}
+test canvImg-8.8 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{101 136 110 145}
+ .c gettags [.c find closest {*}{90 125}]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.9 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{50 134 80 145}
+ .c gettags [.c find closest {*}{70 125}]
+} -cleanup {
+ .c delete all
+} -result {rect}
+test canvImg-8.10 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{50 136 80 145}
+ .c gettags [.c find closest {*}{70 125}]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.11 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{20 134 31 145}
+ .c gettags [.c find closest {*}{40 125}]
+} -cleanup {
+ .c delete all
+} -result {rect}
+test canvImg-8.12 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{20 136 29 145}
+ .c gettags [.c find closest {*}{40 125}]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.13 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{20 100 31 115}
+ .c gettags [.c find closest {*}{40 110}]
+} -cleanup {
+ .c delete all
+} -result {rect}
+test canvImg-8.14 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{20 100 29 115}
+ .c gettags [.c find closest {*}{40 110}]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.15 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{20 70 31 80}
+ .c gettags [.c find closest {*}{40 90}]
+} -cleanup {
+ .c delete all
+} -result {rect}
+test canvImg-8.16 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{20 70 29 79}
+ .c gettags [.c find closest {*}{40 90}]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.17 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{60 70 69 109}
+ .c gettags [.c find closest {*}{70 110}]
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.18 {ImageToArea procedure} -constraints testImageType -setup {
+ .c create image 50 100 -image foo -tags image -anchor nw
+ .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
+} -body {
+ .c coords rect {*}{60 70 71 111}
+ .c gettags [.c find closest {*}{70 110}]
+} -cleanup {
+ .c delete all
+} -result {rect}
.c delete all
-if {[testConstraint testImageType]} {
+
+test canvImg-8.19 {ImageToArea procedure} -constraints testImageType -body {
.c create image 50 100 -image foo -tags image -anchor nw
-}
-test canvImg-8.19 {ImageToArea procedure} testImageType {
.c gettags [.c find overlapping 60 0 70 99]
-} {}
-test canvImg-8.20 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.20 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 60 0 70 99.999]
-} {}
-test canvImg-8.21 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.21 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 60 0 70 101]
-} {image}
-test canvImg-8.22 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.22 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 81 105 120 115]
-} {}
-test canvImg-8.23 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.23 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 80.001 105 120 115]
-} {}
-test canvImg-8.24 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.24 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 79 105 120 115]
-} {image}
-test canvImg-8.25 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.25 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 60 116 70 150]
-} {}
-test canvImg-8.26 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.26 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 60 115.001 70 150]
-} {}
-test canvImg-8.27 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.27 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 60 114 70 150]
-} {image}
-test canvImg-8.28 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.28 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 0 105 49 115]
-} {}
-test canvImg-8.29 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.29 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 0 105 50 114.999]
-} {}
-test canvImg-8.30 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.30 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 0 105 51 115]
-} {image}
-test canvImg-8.31 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.31 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 0 0 49.999 99.999]
-} {}
-test canvImg-8.32 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.32 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 0 0 51 101]
-} {image}
-test canvImg-8.33 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.33 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 80 0 150 100]
-} {}
-test canvImg-8.34 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.34 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 79 0 150 101]
-} {image}
-test canvImg-8.35 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.35 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 80.001 115.001 150 180]
-} {}
-test canvImg-8.36 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.36 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 79 114 150 180]
-} {image}
-test canvImg-8.37 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.37 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 0 115 50 180]
-} {}
-test canvImg-8.38 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.38 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find overlapping 0 114 51 180]
-} {image}
-test canvImg-8.39 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.39 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find enclosed 0 0 200 200]
-} {image}
-test canvImg-8.40 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.40 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find enclosed 49.999 99.999 80.001 115.001]
-} {image}
-test canvImg-8.41 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {image}
+test canvImg-8.41 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find enclosed 51 100 80 115]
-} {}
-test canvImg-8.42 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.42 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find enclosed 50 101 80 115]
-} {}
-test canvImg-8.43 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.43 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find enclosed 50 100 79 115]
-} {}
-test canvImg-8.44 {ImageToArea procedure} testImageType {
+} -cleanup {
+ .c delete all
+} -result {}
+test canvImg-8.44 {ImageToArea procedure} -constraints testImageType -body {
+ .c create image 50 100 -image foo -tags image -anchor nw
.c gettags [.c find enclosed 50 100 80 114]
-} {}
+} -cleanup {
+ .c delete all
+} -result {}
+if {[testConstraint testImageType]} {
+ image delete foo
+}
-test canvImg-9.1 {DisplayImage procedure} testImageType {
+
+test canvImg-9.1 {DisplayImage procedure} -constraints testImageType -setup {
.c delete all
+ image create test foo
+} -body {
.c create image 50 100 -image foo -tags image -anchor nw
.c scale image 25 0 2.0 1.5
.c bbox image
-} {75 150 105 165}
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {75 150 105 165}
-test canvImg-10.1 {TranslateImage procedure} testImageType {
+test canvImg-10.1 {TranslateImage procedure} -constraints testImageType -setup {
.c delete all
+} -body {
+ image create test foo -variable x
.c create image 50 100 -image foo -tags image -anchor nw
update
set x {}
foo changed 2 4 6 8 30 15
update
- set x
-} {{foo display 2 4 6 8 30 30}}
+ return $x
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {{foo display 2 4 6 8 30 30}}
-test canvImg-11.1 {TranslateImage procedure} testImageType {
+test canvImg-11.1 {TranslateImage procedure} -constraints testImageType -setup {
.c delete all
+} -body {
+ image create test foo -variable x
.c create image 50 100 -image foo -tags image -anchor nw
update
set x {}
foo changed 2 4 6 8 40 50
update
- set x
-} {{foo display 0 0 40 50 30 30}}
-test canvImg-11.2 {ImageChangedProc procedure} testImageType {
- .c delete all
+ return $x
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {{foo display 0 0 40 50 30 30}}
+test canvImg-11.2 {ImageChangedProc procedure} -constraints {
+ testImageType
+} -setup {
+ .c delete all
+} -body {
image create test foo -variable x
.c create image 50 100 -image foo -tags image -anchor center
update
set x {}
foo changed 0 0 0 0 40 50
.c bbox image
-} {30 75 70 125}
-test canvImg-11.3 {ImageChangedProc procedure} testImageType {
- .c delete all
+} -cleanup {
+ .c delete all
+ image delete foo
+} -result {30 75 70 125}
+test canvImg-11.3 {ImageChangedProc procedure} -constraints {
+ testImageType
+} -setup {
+ .c delete all
+} -body {
image create test foo -variable x
+ image create test foo2 -variable y
foo changed 0 0 0 0 40 50
+ foo2 changed 0 0 0 0 80 60
+
.c create image 50 100 -image foo -tags image -anchor nw
.c create image 70 110 -image foo2 -anchor nw
update
set y {}
image create test foo -variable x
update
- set y
-} {{foo2 display 0 0 20 40 50 40}}
+ return $y
+} -cleanup {
+ .c delete all
+ image delete foo foo2
+} -result {{foo2 display 0 0 20 40 50 40}}
# cleanup
cleanupTests
return
+
+
diff --git a/tests/canvRect.test b/tests/canvRect.test
index 975c71a..c9f2dfb 100644
--- a/tests/canvRect.test
+++ b/tests/canvRect.test
@@ -6,303 +6,446 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: canvRect.test,v 1.9 2008/07/23 23:24:26 nijtmans Exp $
+# RCS: @(#) $Id: canvRect.test,v 1.10 2008/08/11 21:33:17 aniap Exp $
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
+# Canvas used in every test case of the whole file
canvas .c -width 400 -height 300 -bd 2 -relief sunken
pack .c
-bind .c <1> {
- puts "button down at (%x,%y)"
-}
update
-set i 1
+# Rectangle used in canvRect-1.* tests
.c create rectangle 20 20 80 80 -tag test
-foreach test {
- {-fill #ff0000 #ff0000
- non-existent {unknown color name "non-existent"}}
- {-outline #123456 #123456
- bad_color {unknown color name "bad_color"}}
- {-stipple gray50 gray50
- bogus {bitmap "bogus" not defined}}
- {-tags {test a b c} {test a b c}
- {} {}}
- {-width 6.0 6.0
- abc {bad screen distance "abc"}}
-} {
- lassign $test name goodValue goodResult badValue badResult
- test canvRect-1.$i "configuration options: good value for $name" {
- .c itemconfigure test $name $goodValue
- list [lindex [.c itemconfigure test $name] 4] [.c itemcget test $name]
- } [list $goodResult $goodResult]
- incr i
- if {$badValue ne ""} {
- test canvRect-1.$i "configuration options: bad value for $name" -body {
- .c itemconfigure test $name $badValue
- } -returnCodes error -result $badResult
- }
- incr i
-}
-test canvRect-1.$i {configuration options} {
+test canvRect-1.1 {configuration options: good value for -fill} -body {
+ .c itemconfigure test -fill #ff0000
+ list [.c itemcget test -fill] [lindex [.c itemconfigure test -fill] 4]
+} -result {{#ff0000} #ff0000}
+test canvRect-1.2 {configuration options: bad value for -fill} -body {
+ .c itemconfigure test -fill non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test canvRect-1.3 {configuration options: good value for -outline} -body {
+ .c itemconfigure test -outline #123456
+ list [.c itemcget test -outline] [lindex [.c itemconfigure test -outline] 4]
+} -result {{#123456} #123456}
+test canvRect-1.4 {configuration options: bad value for -outline} -body {
+ .c itemconfigure test -outline non-existent
+} -returnCodes error -result {unknown color name "non-existent"}
+test canvRect-1.5 {configuration options: good value for -stipple } -body {
+ .c itemconfigure test -stipple gray50
+ list [.c itemcget test -stipple ] [lindex [.c itemconfigure test -stipple ] 4]
+} -result {gray50 gray50}
+test canvRect-1.6 {configuration options: bad value for -stipple } -body {
+ .c itemconfigure test -stipple bogus
+} -returnCodes error -result {bitmap "bogus" not defined}
+test canvRect-1.7 {configuration options: good value for -tags} -body {
+ .c itemconfigure test -tags {test a b c}
+ list [.c itemcget test -tags] [lindex [.c itemconfigure test -tags] 4]
+} -result {{test a b c} {test a b c}}
+test canvRect-1.8 {configuration options} -body {
.c itemconfigure test -tags {test xyz}
.c itemcget xyz -tags
-} {test xyz}
+} -result {test xyz}
+test canvRect-1.9 {configuration options: good value for -width} -body {
+ .c itemconfigure test -width 6.0
+ list [.c itemcget test -width] [lindex [.c itemconfigure test -width] 4]
+} -result {6.0 6.0}
+test canvRect-1.10 {configuration options: bad value for -width} -body {
+ .c itemconfigure test -width abc
+} -returnCodes error -result {bad screen distance "abc"}
+.c delete withtag all
+
-test canvRect-2.1 {CreateRectOval procedure} {
- list [catch {.c create rect} msg] $msg
-} {1 {wrong # args: should be ".c create rect coords ?arg ...?"}}
-test canvRect-2.2 {CreateRectOval procedure} {
- list [catch {.c create oval x y z} msg] $msg
-} {1 {wrong # coordinates: expected 0 or 4, got 3}}
-test canvRect-2.3 {CreateRectOval procedure} {
- list [catch {.c create rectangle x 2 3 4} msg] $msg
-} {1 {bad screen distance "x"}}
-test canvRect-2.4 {CreateRectOval procedure} {
- list [catch {.c create rectangle 1 y 3 4} msg] $msg
-} {1 {bad screen distance "y"}}
-test canvRect-2.5 {CreateRectOval procedure} {
- list [catch {.c create rectangle 1 2 z 4} msg] $msg
-} {1 {bad screen distance "z"}}
-test canvRect-2.6 {CreateRectOval procedure} {
- list [catch {.c create rectangle 1 2 3 q} msg] $msg
-} {1 {bad screen distance "q"}}
-test canvRect-2.7 {CreateRectOval procedure} {
+test canvRect-2.1 {CreateRectOval procedure} -body {
+ .c create rect
+} -returnCodes error -result {wrong # args: should be ".c create rect coords ?arg ...?"}
+test canvRect-2.2 {CreateRectOval procedure} -body {
+ .c create oval x y z
+} -returnCodes error -result {wrong # coordinates: expected 0 or 4, got 3}
+test canvRect-2.3 {CreateRectOval procedure} -body {
+ .c create rectangle x 2 3 4
+} -returnCodes error -result {bad screen distance "x"}
+test canvRect-2.4 {CreateRectOval procedure} -body {
+ .c create rectangle 1 y 3 4
+} -returnCodes error -result {bad screen distance "y"}
+test canvRect-2.5 {CreateRectOval procedure} -body {
+ .c create rectangle 1 2 z 4
+} -returnCodes error -result {bad screen distance "z"}
+test canvRect-2.6 {CreateRectOval procedure} -body {
+ .c create rectangle 1 2 3 q
+} -returnCodes error -result {bad screen distance "q"}
+test canvRect-2.7 {CreateRectOval procedure} -body {
.c create rectangle 1 2 3 4 -tags x
set result {}
foreach element [.c coords x] {
- lappend result [format %.1f $element]
+ lappend result [format %.1f $element]
}
set result
-} {1.0 2.0 3.0 4.0}
-test canvRect-2.8 {CreateRectOval procedure} {
- list [catch {.c create rectangle 1 2 3 4 -gorp foo} msg] $msg
-} {1 {unknown option "-gorp"}}
-
+} -result {1.0 2.0 3.0 4.0}
+test canvRect-2.8 {CreateRectOval procedure} -body {
+ .c create rectangle 1 2 3 4 -gorp foo
+} -returnCodes error -result {unknown option "-gorp"}
.c delete withtag all
-.c create rectangle 10 20 30 40 -tags x
-test canvRect-3.1 {RectOvalCoords procedure} {
+
+
+test canvRect-3.1 {RectOvalCoords procedure} -body {
+ .c create rectangle 10 20 30 40 -tags x
set result {}
foreach element [.c coords x] {
- lappend result [format %.1f $element]
+ lappend result [format %.1f $element]
}
- set result
-} {10.0 20.0 30.0 40.0}
-test canvRect-3.2 {RectOvalCoords procedure} {
- list [catch {.c coords x a 2 3 4} msg] $msg
-} {1 {bad screen distance "a"}}
-test canvRect-3.3 {RectOvalCoords procedure} {
- list [catch {.c coords x 1 b 3 4} msg] $msg
-} {1 {bad screen distance "b"}}
-test canvRect-3.4 {RectOvalCoords procedure} {
- list [catch {.c coords x 1 2 c 4} msg] $msg
-} {1 {bad screen distance "c"}}
-test canvRect-3.5 {RectOvalCoords procedure} {
- list [catch {.c coords x 1 2 3 d} msg] $msg
-} {1 {bad screen distance "d"}}
-test canvRect-3.6 {RectOvalCoords procedure} {nonPortable} {
+ return $result
+} -cleanup {
+ .c delete withtag all
+} -result {10.0 20.0 30.0 40.0}
+test canvRect-3.2 {RectOvalCoords procedure} -body {
+ .c create rectangle 10 20 30 40 -tags x
+ .c coords x a 2 3 4
+} -cleanup {
+ .c delete withtag all
+} -returnCodes error -result {bad screen distance "a"}
+test canvRect-3.3 {RectOvalCoords procedure} -body {
+ .c create rectangle 10 20 30 40 -tags x
+ .c coords x 1 b 3 4
+} -cleanup {
+ .c delete withtag all
+} -returnCodes error -result {bad screen distance "b"}
+test canvRect-3.4 {RectOvalCoords procedure} -body {
+ .c create rectangle 10 20 30 40 -tags x
+ .c coords x 1 2 c 4
+} -cleanup {
+ .c delete withtag all
+} -returnCodes error -result {bad screen distance "c"}
+test canvRect-3.5 {RectOvalCoords procedure} -body {
+ .c create rectangle 10 20 30 40 -tags x
+ .c coords x 1 2 3 d
+} -cleanup {
+ .c delete withtag all
+} -returnCodes error -result {bad screen distance "d"}
+test canvRect-3.6 {RectOvalCoords procedure} -constraints {
+ nonPortable
+} -body {
+ .c create rectangle 10 20 30 40 -tags x
# Non-portable due to rounding differences.
.c coords x 10 25 15 40
.c bbox x
-} {9 24 16 41}
-test canvRect-3.7 {RectOvalCoords procedure} {
- list [catch {.c coords x 1 2 3 4 5} msg] $msg
-} {1 {wrong # coordinates: expected 0 or 4, got 5}}
+} -cleanup {
+ .c delete withtag all
+} -result {9 24 16 41}
+test canvRect-3.7 {RectOvalCoords procedure} -body {
+ .c create rectangle 10 20 30 40 -tags x
+ .c coords x 1 2 3 4 5
+} -cleanup {
+ .c delete withtag all
+} -returnCodes error -result {wrong # coordinates: expected 0 or 4, got 5}
-.c delete withtag all
-.c create rectangle 10 20 30 40 -tags x -width 1
-test canvRect-4.1 {ConfigureRectOval procedure} {
- list [catch {.c itemconfigure x -width abc} msg] $msg \
- [.c itemcget x -width]
-} {1 {bad screen distance "abc"} 1.0}
-test canvRect-4.2 {ConfigureRectOval procedure} {
- list [catch {.c itemconfigure x -width -5} msg] $msg
-} {1 {bad screen distance "-5"}}
-test canvRect-4.3 {ConfigureRectOval procedure} {nonPortable} {
- # Non-portable due to rounding differences.
+
+test canvRect-4.1 {ConfigureRectOval procedure} -body {
+ .c create rectangle 10 20 30 40 -tags x -width 1
+ .c itemconfigure x -width abc
+} -cleanup {
+ .c delete withtag all
+} -returnCodes error -result {bad screen distance "abc"}
+test canvRect-4.2 {ConfigureRectOval procedure} -body {
+ .c create rectangle 10 20 30 40 -tags x -width 1
+ catch {.c itemconfigure x -width abc}
+ .c itemcget x -width
+} -cleanup {
+ .c delete withtag all
+} -result {1.0}
+test canvRect-4.3 {ConfigureRectOval procedure} -body {
+ .c create rectangle 10 20 30 40 -tags x -width 1
+ .c itemconfigure x -width -5
+} -cleanup {
+ .c delete withtag all
+} -returnCodes error -result {bad screen distance "-5"}
+test canvRect-4.4 {ConfigureRectOval procedure} -constraints nonPortable -body {
+ # Non-portable due to rounding differences
+ .c create rectangle 10 20 30 40 -tags x -width 1
.c itemconfigure x -width 10
.c bbox x
-} {5 15 35 45}
+} -cleanup {
+ .c delete withtag all
+} -result {5 15 35 45}
+
# I can't come up with any good tests for DeleteRectOval.
-.c delete withtag all
-.c create rectangle 10 20 30 40 -tags x -width 1 -outline {}
-test canvRect-5.1 {ComputeRectOvalBbox procedure} {nonPortable} {
+test canvRect-5.1 {ComputeRectOvalBbox procedure} -constraints nonPortable -body {
# Non-portable due to rounding differences:
+ .c create rectangle 10 20 30 40 -tags x -width 1 -outline {}
.c coords x 20 15 10 5
.c bbox x
-} {10 5 20 15}
-test canvRect-5.2 {ComputeRectOvalBbox procedure} {nonPortable} {
+} -cleanup {
+ .c delete withtag all
+} -result {10 5 20 15}
+test canvRect-5.2 {ComputeRectOvalBbox procedure} -constraints nonPortable -body {
# Non-portable due to rounding differences:
+ .c create rectangle 10 20 30 40 -tags x -width 1 -outline {}
.c coords x 10 20 30 10
.c itemconfigure x -width 1 -outline red
.c bbox x
-} {9 9 31 21}
-test canvRect-5.3 {ComputeRectOvalBbox procedure} {nonPortable} {
+} -cleanup {
+ .c delete withtag all
+} -result {9 9 31 21}
+test canvRect-5.3 {ComputeRectOvalBbox procedure} -constraints nonPortable -body {
# Non-portable due to rounding differences:
+ .c create rectangle 10 20 30 40 -tags x -width 1 -outline {}
.c coords x 10 20 30 10
.c itemconfigure x -width 2 -outline red
.c bbox x
-} {9 9 31 21}
-test canvRect-5.4 {ComputeRectOvalBbox procedure} {nonPortable} {
+} -cleanup {
+ .c delete withtag all
+} -result {9 9 31 21}
+test canvRect-5.4 {ComputeRectOvalBbox procedure} -constraints nonPortable -body {
# Non-portable due to rounding differences:
+ .c create rectangle 10 20 30 40 -tags x -width 1 -outline {}
.c coords x 10 20 30 10
.c itemconfigure x -width 3 -outline red
.c bbox x
-} {8 8 32 22}
+} -cleanup {
+ .c delete withtag all
+} -result {8 8 32 22}
# I can't come up with any good tests for DisplayRectOval.
-.c delete withtag all
-set x [.c create rectangle 10 20 30 35 -tags x -fill green]
-set y [.c create rectangle 15 25 25 30 -tags y -fill red]
-test canvRect-6.1 {RectToPoint procedure} {
+test canvRect-6.1 {RectToPoint procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -tags x -fill green]
+ set yId [.c create rectangle 15 25 25 30 -tags y -fill red]
.c itemconfigure y -outline {}
- list [.c find closest 14.9 28] [.c find closest 15.1 28] \
- [.c find closest 24.9 28] [.c find closest 25.1 28]
-} "$x $y $y $x"
-test canvRect-6.2 {RectToPoint procedure} {
+ list [expr {[.c find closest 14.9 28] eq $xId}] \
+ [expr {[.c find closest 15.1 28] eq $yId}] \
+ [expr {[.c find closest 24.9 28] eq $yId}] \
+ [expr {[.c find closest 25.1 28] eq $xId}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1}
+test canvRect-6.2 {RectToPoint procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -tags x -fill green]
+ set yId [.c create rectangle 15 25 25 30 -tags y -fill red]
.c itemconfigure y -outline {}
- list [.c find closest 20 24.9] [.c find closest 20 25.1] \
- [.c find closest 20 29.9] [.c find closest 20 30.1]
-} "$x $y $y $x"
-test canvRect-6.3 {RectToPoint procedure} {
+ list [expr {[.c find closest 20 24.9] eq $xId}] \
+ [expr {[.c find closest 20 25.1] eq $yId}] \
+ [expr {[.c find closest 20 29.9] eq $yId}] \
+ [expr {[.c find closest 20 30.1] eq $xId}]
+
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1}
+test canvRect-6.3 {RectToPoint procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -tags x -fill green]
+ set yId [.c create rectangle 15 25 25 30 -tags y -fill red]
.c itemconfigure y -width 1 -outline black
- list [.c find closest 14.4 28] [.c find closest 14.6 28] \
- [.c find closest 25.4 28] [.c find closest 25.6 28]
-} "$x $y $y $x"
-test canvRect-6.4 {RectToPoint procedure} {
+ list [expr {[.c find closest 14.4 28] eq $xId}] \
+ [expr {[.c find closest 14.6 28] eq $yId}] \
+ [expr {[.c find closest 25.4 28] eq $yId}] \
+ [expr {[.c find closest 25.6 28] eq $xId}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1}
+test canvRect-6.4 {RectToPoint procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -tags x -fill green]
+ set yId [.c create rectangle 15 25 25 30 -tags y -fill red]
.c itemconfigure y -width 1 -outline black
- list [.c find closest 20 24.4] [.c find closest 20 24.6] \
- [.c find closest 20 30.4] [.c find closest 20 30.6]
-} "$x $y $y $x"
-.c itemconfigure x -fill {} -outline black -width 3
-.c itemconfigure y -outline {}
-test canvRect-6.5 {RectToPoint procedure} {
- list [.c find closest 13.2 28] [.c find closest 13.3 28] \
- [.c find closest 26.7 28] [.c find closest 26.8 28]
-} "$x $y $y $x"
-test canvRect-6.6 {RectToPoint procedure} {
- list [.c find closest 20 23.2] [.c find closest 20 23.3] \
- [.c find closest 20 31.7] [.c find closest 20 31.8]
-} "$x $y $y $x"
-.c delete withtag all
-set x [.c create rectangle 10 20 30 40 -outline {} -fill black]
-set y [.c create rectangle 40 40 50 50 -outline {} -fill black]
-test canvRect-6.7 {RectToPoint procedure} {
- list [.c find closest 35 35] [.c find closest 36 36] \
- [.c find closest 37 37] [.c find closest 38 38]
-} "$x $y $y $y"
+ list [expr {[.c find closest 20 24.4] eq $xId}] \
+ [expr {[.c find closest 20 24.6] eq $yId}] \
+ [expr {[.c find closest 20 30.4] eq $yId}] \
+ [expr {[.c find closest 20 30.6] eq $xId}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1}
-.c delete withtag all
-set x [.c create rectangle 10 20 30 35 -fill green -outline {}]
-set y [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
-set z [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
-test canvRect-7.1 {RectToArea procedure} {
- list [.c find overlapping 20 50 38 60] \
- [.c find overlapping 20 50 39 60] \
- [.c find overlapping 20 50 70 60] \
- [.c find overlapping 61 50 70 60] \
- [.c find overlapping 62 50 70 60]
-} "{} $y $y $y {}"
-test canvRect-7.2 {RectToArea procedure} {
- list [.c find overlapping 45 20 55 43] \
- [.c find overlapping 45 20 55 44] \
- [.c find overlapping 45 20 55 80] \
- [.c find overlapping 45 71 55 80] \
- [.c find overlapping 45 72 55 80]
-} "{} $y $y $y {}"
-test canvRect-7.3 {RectToArea procedure} {
- list [.c find overlapping 5 25 9.9 30] [.c find overlapping 5 25 10.1 30]
-} "{} $x"
-test canvRect-7.4 {RectToArea procedure} {
- list [.c find overlapping 102 152 118 168] \
- [.c find overlapping 101 152 118 168] \
- [.c find overlapping 102 151 118 168] \
- [.c find overlapping 102 152 119 168] \
- [.c find overlapping 102 152 118 169]
-} "{} $z $z $z $z"
-test canvRect-7.5 {RectToArea procedure} {
- list [.c find enclosed 20 40 38 80] \
- [.c find enclosed 20 40 39 80] \
- [.c find enclosed 20 40 70 80] \
- [.c find enclosed 61 40 70 80] \
- [.c find enclosed 62 40 70 80]
-} "{} {} $y {} {}"
-test canvRect-7.6 {RectToArea procedure} {
- list [.c find enclosed 20 20 65 43] \
- [.c find enclosed 20 20 65 44] \
- [.c find enclosed 20 20 65 80] \
- [.c find enclosed 20 71 65 80] \
- [.c find enclosed 20 72 65 80]
-} "{} {} $y {} {}"
+test canvRect-6.5 {RectToPoint procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -tags x -fill green]
+ set yId [.c create rectangle 15 25 25 30 -tags y -fill red]
+ .c itemconfigure x -fill {} -outline black -width 3
+ .c itemconfigure y -outline {}
+ list [expr {[.c find closest 13.2 28] eq $xId}] \
+ [expr {[.c find closest 13.3 28] eq $yId}] \
+ [expr {[.c find closest 26.7 28] eq $yId}] \
+ [expr {[.c find closest 26.8 28] eq $xId}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1}
+test canvRect-6.6 {RectToPoint procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -tags x -fill green]
+ set yId [.c create rectangle 15 25 25 30 -tags y -fill red]
+ .c itemconfigure x -fill {} -outline black -width 3
+ .c itemconfigure y -outline {}
+ list [expr {[.c find closest 20 23.2] eq $xId}] \
+ [expr {[.c find closest 20 23.3] eq $yId}] \
+ [expr {[.c find closest 20 31.7] eq $yId}] \
+ [expr {[.c find closest 20 31.8] eq $xId}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1}
+
+test canvRect-6.7 {RectToPoint procedure} -body {
+ set xId [.c create rectangle 10 20 30 40 -outline {} -fill black]
+ set yId [.c create rectangle 40 40 50 50 -outline {} -fill black]
+ list [expr {[.c find closest 35 35] eq $xId}] \
+ [expr {[.c find closest 36 36] eq $yId}] \
+ [expr {[.c find closest 37 37] eq $yId}] \
+ [expr {[.c find closest 38 38] eq $yId}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1}
-.c delete withtag all
-set x [.c create oval 50 100 200 150 -fill green -outline {}]
-set y [.c create oval 50 100 200 150 -fill red -outline black -width 3]
-set z [.c create oval 50 100 200 150 -fill {} -outline black -width 3]
-test canvRect-8.1 {OvalToArea procedure} {
- list [.c find overlapping 20 120 48 130] \
- [.c find overlapping 20 120 49 130] \
- [.c find overlapping 20 120 50.2 130] \
- [.c find overlapping 20 120 300 130] \
- [.c find overlapping 60 120 190 130] \
- [.c find overlapping 199.9 120 300 130] \
- [.c find overlapping 201 120 300 130] \
- [.c find overlapping 202 120 300 130]
-} "{} {$y $z} {$x $y $z} {$x $y $z} {$x $y} {$x $y $z} {$y $z} {}"
-test canvRect-8.2 {OvalToArea procedure} {
- list [.c find overlapping 100 50 150 98] \
- [.c find overlapping 100 50 150 99] \
- [.c find overlapping 100 50 150 100.1] \
- [.c find overlapping 100 50 150 200] \
- [.c find overlapping 100 110 150 140] \
- [.c find overlapping 100 149.9 150 200] \
- [.c find overlapping 100 151 150 200] \
- [.c find overlapping 100 152 150 200]
-} "{} {$y $z} {$x $y $z} {$x $y $z} {$x $y} {$x $y $z} {$y $z} {}"
-test canvRect-8.3 {OvalToArea procedure} {
- list [.c find overlapping 176 104 177 105] \
- [.c find overlapping 187 116 188 117] \
- [.c find overlapping 192 142 193 143] \
- [.c find overlapping 180 138 181 139] \
- [.c find overlapping 61 142 62 143] \
- [.c find overlapping 65 137 66 136] \
- [.c find overlapping 62 108 63 109] \
- [.c find overlapping 68 115 69 116]
-} "{} {$x $y} {} {$x $y} {} {$x $y} {} {$x $y}"
-test canvRect-9.1 {ScaleRectOval procedure} {
+test canvRect-7.1 {RectToArea procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -fill green -outline {}]
+ set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
+ set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
+ list [expr {[.c find overlapping 20 50 38 60] eq {}}] \
+ [expr {[.c find overlapping 20 50 39 60] eq $yId}] \
+ [expr {[.c find overlapping 20 50 70 60] eq $yId}] \
+ [expr {[.c find overlapping 61 50 70 60] eq $yId}] \
+ [expr {[.c find overlapping 62 50 70 60] eq {}}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1 1}
+test canvRect-7.2 {RectToArea procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -fill green -outline {}]
+ set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
+ set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
+ list [expr {[.c find overlapping 45 20 55 43] eq {}}] \
+ [expr {[.c find overlapping 45 20 55 44] eq $yId}] \
+ [expr {[.c find overlapping 45 20 55 80] eq $yId}] \
+ [expr {[.c find overlapping 45 71 55 80] eq $yId}] \
+ [expr {[.c find overlapping 45 72 55 80] eq {}}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1 1}
+test canvRect-7.3 {RectToArea procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -fill green -outline {}]
+ set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
+ set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
+ list [expr {[.c find overlapping 5 25 9.9 30] eq {}}] \
+ [expr {[.c find overlapping 5 25 10.1 30] eq $xId}]
+} -cleanup {
+ .c delete all
+} -result {1 1}
+test canvRect-7.4 {RectToArea procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -fill green -outline {}]
+ set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
+ set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
+ list [expr {[.c find overlapping 102 152 118 168] eq {}}]\
+ [expr {[.c find overlapping 101 152 118 168] eq $zId}] \
+ [expr {[.c find overlapping 102 151 118 168] eq $zId}] \
+ [expr {[.c find overlapping 102 152 119 168] eq $zId}] \
+ [expr {[.c find overlapping 102 152 118 169] eq $zId}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1 1}
+test canvRect-7.5 {RectToArea procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -fill green -outline {}]
+ set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
+ set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
+ list [expr {[.c find enclosed 20 40 38 80] eq {}}] \
+ [expr {[.c find enclosed 20 40 39 80] eq {}}] \
+ [expr {[.c find enclosed 20 40 70 80] eq $yId}] \
+ [expr {[.c find enclosed 61 40 70 80] eq {}}] \
+ [expr {[.c find enclosed 62 40 70 80] eq {}}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1 1}
+test canvRect-7.6 {RectToArea procedure} -body {
+ set xId [.c create rectangle 10 20 30 35 -fill green -outline {}]
+ set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
+ set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
+ list [expr {[.c find enclosed 20 20 65 43] eq {}}] \
+ [expr {[.c find enclosed 20 20 65 44] eq {}}] \
+ [expr {[.c find enclosed 20 20 65 80] eq $yId}] \
+ [expr {[.c find enclosed 20 71 65 80] eq {}}] \
+ [expr {[.c find enclosed 20 72 65 80] eq {}}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1 1}
+
+
+test canvRect-8.1 {OvalToArea procedure} -body {
+ set xId [.c create oval 50 100 200 150 -fill green -outline {}]
+ set yId [.c create oval 50 100 200 150 -fill red -outline black -width 3]
+ set zId [.c create oval 50 100 200 150 -fill {} -outline black -width 3]
+ list [expr {[.c find overlapping 20 120 48 130] eq {}}] \
+ [expr {[.c find overlapping 20 120 49 130] eq "$yId $zId"}] \
+ [expr {[.c find overlapping 20 120 50.2 130] eq "$xId $yId $zId"}] \
+ [expr {[.c find overlapping 20 120 300 130] eq "$xId $yId $zId"}] \
+ [expr {[.c find overlapping 60 120 190 130] eq "$xId $yId"}] \
+ [expr {[.c find overlapping 199.9 120 300 130] eq "$xId $yId $zId"}] \
+ [expr {[.c find overlapping 201 120 300 130] eq "$yId $zId"}] \
+ [expr {[.c find overlapping 202 120 300 130] eq {}}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1 1 1 1 1}
+test canvRect-8.2 {OvalToArea procedure} -body {
+ set xId [.c create oval 50 100 200 150 -fill green -outline {}]
+ set yId [.c create oval 50 100 200 150 -fill red -outline black -width 3]
+ set zId [.c create oval 50 100 200 150 -fill {} -outline black -width 3]
+ list [expr {[.c find overlapping 100 50 150 98] eq {}}] \
+ [expr {[.c find overlapping 100 50 150 99] eq "$yId $zId"}] \
+ [expr {[.c find overlapping 100 50 150 100.1] eq "$xId $yId $zId"}] \
+ [expr {[.c find overlapping 100 50 150 200] eq "$xId $yId $zId"}] \
+ [expr {[.c find overlapping 100 110 150 140] eq "$xId $yId"}] \
+ [expr {[.c find overlapping 100 149.9 150 200] eq "$xId $yId $zId"}] \
+ [expr {[.c find overlapping 100 151 150 200] eq "$yId $zId"}] \
+ [expr {[.c find overlapping 100 152 150 200] eq {}}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1 1 1 1 1}
+test canvRect-8.3 {OvalToArea procedure} -body {
+ set xId [.c create oval 50 100 200 150 -fill green -outline {}]
+ set yId [.c create oval 50 100 200 150 -fill red -outline black -width 3]
+ set zId [.c create oval 50 100 200 150 -fill {} -outline black -width 3]
+ list [expr {[.c find overlapping 176 104 177 105] eq {}}] \
+ [expr {[.c find overlapping 187 116 188 117] eq "$xId $yId"}] \
+ [expr {[.c find overlapping 192 142 193 143] eq {}}] \
+ [expr {[.c find overlapping 180 138 181 139] eq "$xId $yId"}] \
+ [expr {[.c find overlapping 61 142 62 143] eq {}}] \
+ [expr {[.c find overlapping 65 137 66 136] eq "$xId $yId"}] \
+ [expr {[.c find overlapping 62 108 63 109] eq {}}] \
+ [expr {[.c find overlapping 68 115 69 116] eq "$xId $yId"}]
+} -cleanup {
+ .c delete all
+} -result {1 1 1 1 1 1 1 1}
+
+
+test canvRect-9.1 {ScaleRectOval procedure} -setup {
.c delete withtag all
+} -body {
.c create rect 100 300 200 350 -tags x
.c scale x 50 100 2 4
.c coords x
-} {150.0 900.0 350.0 1100.0}
+} -result {150.0 900.0 350.0 1100.0}
-test canvRect-10.1 {TranslateRectOval procedure} {
+test canvRect-10.1 {TranslateRectOval procedure} -setup {
.c delete withtag all
+} -body {
.c create rect 100 300 200 350 -tags x
.c move x 100 -10
.c coords x
-} {200.0 290.0 300.0 340.0}
+} -result {200.0 290.0 300.0 340.0}
+
-# This test is non-portable because different color information
-# will get generated on different displays (e.g. mono displays
-# vs. color).
-test canvRect-11.1 {RectOvalToPostscript procedure} {nonPortable macCrash} {
+test canvRect-11.1 {RectOvalToPostscript procedure} -constraints {
+ nonPortable macCrash
+} -setup {
+ .c delete withtag all
+} -body {
# Crashes on Mac because the XGetImage() call isn't implemented, causing a
# dereference of NULL.
-
+ # This test is non-portable because different color information
+ # will get generated on different displays (e.g. mono displays
+ # vs. color).
.c configure -bd 0 -highlightthickness 0
- .c delete withtag all
.c create rect 50 60 90 80 -fill black -stipple gray50 -outline {}
.c create oval 100 150 200 200 -fill {} -outline #ff0000 -width 5
update
set x [.c postscript]
string range $x [string first "-200 -150 translate" $x] end
-} {-200 -150 translate
+} -result {-200 -150 translate
0 300 moveto 400 300 lineto 400 0 lineto 0 0 lineto closepath clip newpath
gsave
50 240 moveto 40 0 rlineto 0 -20 rlineto -40 0 rlineto closepath
@@ -328,3 +471,7 @@ end
# cleanup
cleanupTests
return
+
+
+
+
diff --git a/tests/canvText.test b/tests/canvText.test
index 5367681..2e7ac54 100644
--- a/tests/canvText.test
+++ b/tests/canvText.test
@@ -6,117 +6,191 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: canvText.test,v 1.17 2008/07/23 23:24:25 nijtmans Exp $
+# RCS: @(#) $Id: canvText.test,v 1.18 2008/08/11 21:33:17 aniap Exp $
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
+# Canvas used in 1.* - 17.* tests
canvas .c -width 400 -height 300 -bd 2 -relief sunken
pack .c
update
-set i 1
+# Item used in 1.* tests
.c create text 20 20 -tag test
-
-set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
-set ay [font metrics $font -linespace]
-set ax [font measure $font 0]
-
-
-foreach test {
- {-anchor nw nw xyz {bad anchor position "xyz": must be n, ne, e, se, s, sw, w, nw, or center}}
- {-fill #ff0000 #ff0000 xyz {unknown color name "xyz"}}
- {-fill {} {} {} {}}
- {-font {Times 40} {Times 40} {} {font "" doesn't exist}}
- {-justify left left xyz {bad justification "xyz": must be left, right, or center}}
- {-stipple gray50 gray50 xyz {bitmap "xyz" not defined}}
- {-tags {test a b c} {test a b c} {} {}}
- {-text xyz xyz {} {}}
- {-underline 0 0 xyz {expected integer but got "xyz"}}
- {-width 6 6 xyz {bad screen distance "xyz"}}
-} {
- lassign $test name goodValue goodResult badValue badResult
- test canvText-1.$i "configuration options: good value for $name" {
- .c itemconfigure test $name $goodValue
- list [lindex [.c itemconfigure test $name] 4] [.c itemcget test $name]
- } [list $goodResult $goodResult]
- incr i
- if {$badValue ne ""} {
- test canvText-1.$i "configuration options: bad value for $name" -body {
- .c itemconfigure test $name $badValue
- } -returnCodes error -result $badResult
- }
- incr i
-}
-test canvText-1.$i {configuration options} {
- .c itemconfigure test -tags {test xyz}
- .c itemcget xyz -tags
-} {test xyz}
-
+test canvText-1.1 {configuration options: good value for "anchor"} -body {
+ .c itemconfigure test -anchor nw
+ list [lindex [.c itemconfigure test -anchor] 4] [.c itemcget test -anchor]
+} -result {nw nw}
+test canvasText-1.2 {configuration options: bad value for "anchor"} -body {
+ .c itemconfigure test -anchor xyz
+} -returnCodes error -result {bad anchor position "xyz": must be n, ne, e, se, s, sw, w, nw, or center}
+
+test canvText-1.3 {configuration options: good value for "fill"} -body {
+ .c itemconfigure test -fill #ff0000
+ list [lindex [.c itemconfigure test -fill] 4] [.c itemcget test -fill]
+} -result {{#ff0000} #ff0000}
+test canvasText-1.4 {configuration options: bad value for "fill"} -body {
+ .c itemconfigure test -fill xyz
+} -returnCodes error -result {unknown color name "xyz"}
+test canvText-1.5 {configuration options: good value for "fill"} -body {
+ .c itemconfigure test -fill {}
+ list [lindex [.c itemconfigure test -fill] 4] [.c itemcget test -fill]
+} -result {{} {}}
+
+test canvText-1.6 {configuration options: good value for "font"} -body {
+ .c itemconfigure test -font {Times 40}
+ list [lindex [.c itemconfigure test -font] 4] [.c itemcget test -font]
+} -result {{Times 40} {Times 40}}
+test canvasText-1.7 {configuration options: bad value for "font"} -body {
+ .c itemconfigure test -font {}
+} -returnCodes error -result {font "" doesn't exist}
+
+test canvText-1.8 {configuration options: good value for "justify"} -body {
+ .c itemconfigure test -justify left
+ list [lindex [.c itemconfigure test -justify] 4] [.c itemcget test -justify]
+} -result {left left}
+test canvasText-1.9 {configuration options: bad value for "justify"} -body {
+ .c itemconfigure test -justify xyz
+} -returnCodes error -result {bad justification "xyz": must be left, right, or center}
+
+test canvText-1.10 {configuration options: good value for "stipple"} -body {
+ .c itemconfigure test -stipple gray50
+ list [lindex [.c itemconfigure test -stipple] 4] [.c itemcget test -stipple]
+} -result {gray50 gray50}
+test canvasText-1.11 {configuration options: bad value for "stipple"} -body {
+ .c itemconfigure test -stipple xyz
+} -returnCodes error -result {bitmap "xyz" not defined}
+
+test canvText-1.12 {configuration options: good value for "underline"} -body {
+ .c itemconfigure test -underline 0
+ list [lindex [.c itemconfigure test -underline] 4] [.c itemcget test -underline]
+} -result {0 0}
+test canvasText-1.13 {configuration options: bad value for "underline"} -body {
+ .c itemconfigure test -underline xyz
+} -returnCodes error -result {expected integer but got "xyz"}
+
+test canvText-1.14 {configuration options: good value for "width"} -body {
+ .c itemconfigure test -width 6
+ list [lindex [.c itemconfigure test -width] 4] [.c itemcget test -width]
+} -result {6 6}
+test canvasText-1.15 {configuration options: bad value for "width"} -body {
+ .c itemconfigure test -width xyz
+} -returnCodes error -result {bad screen distance "xyz"}
+
+test canvText-1.16 {configuration options: good value for "tags"} -body {
+ .c itemconfigure test -tags {test a b c}
+ list [lindex [.c itemconfigure test -tags] 4] [.c itemcget test -tags]
+} -result {{test a b c} {test a b c}}
.c delete test
-.c create text 20 20 -tag test
-test canvText-2.1 {CreateText procedure: args} {
- list [catch {.c create text} msg] $msg
-} {1 {wrong # args: should be ".c create text coords ?arg ...?"}}
-test canvText-2.2 {CreateText procedure: args} {
- list [catch {.c create text xyz 0} msg] $msg
-} {1 {bad screen distance "xyz"}}
-test canvText-2.3 {CreateText procedure: args} {
- list [catch {.c create text 0 xyz} msg] $msg
-} {1 {bad screen distance "xyz"}}
-test canvText-2.4 {CreateText procedure: args} {
- list [catch {.c create text 0 0 -xyz xyz} msg] $msg
-} {1 {unknown option "-xyz"}}
-test canvText-2.5 {CreateText procedure} {
+
+test canvText-2.1 {CreateText procedure: args} -body {
+ .c create text
+} -returnCodes {error} -result {wrong # args: should be ".c create text coords ?arg ...?"}
+test canvText-2.2 {CreateText procedure: args} -body {
+ .c create text xyz 0
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {bad screen distance "xyz"}
+test canvText-2.3 {CreateText procedure: args} -body {
+ .c create text 0 xyz
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {bad screen distance "xyz"}
+test canvText-2.4 {CreateText procedure: args} -body {
+ .c create text 0 0 -xyz xyz
+} -cleanup {
+ .c delete all
+} -returnCodes {error} -result {unknown option "-xyz"}
+test canvText-2.5 {CreateText procedure} -body {
.c create text 0 0 -tags x
- set x [.c coords x]
+ .c coords x
+} -cleanup {
.c delete x
- set x
-} {0.0 0.0}
+} -result {0.0 0.0}
-focus -force .c
-.c focus test
-.c coords test 0 0
-update
-test canvText-3.1 {TextCoords procedure} {
+test canvText-3.1 {TextCoords procedure} -body {
+ .c create text 20 20 -tag test
+ .c coords test 0 0
+ update
.c coords test
-} {0.0 0.0}
-test canvText-3.2 {TextCoords procedure} {
- list [catch {.c coords test xyz 0} msg] $msg
-} {1 {bad screen distance "xyz"}}
-test canvText-3.3 {TextCoords procedure} {
- list [catch {.c coords test 0 xyz} msg] $msg
-} {1 {bad screen distance "xyz"}}
-test canvText-3.4 {TextCoords procedure} {
+} -cleanup {
+ .c delete test
+} -result {0.0 0.0}
+test canvText-3.2 {TextCoords procedure} -setup {
+ .c create text 20 20 -tag test
+} -body {
+ .c coords test xyz 0
+} -cleanup {
+ .c delete test
+} -returnCodes {error} -result {bad screen distance "xyz"}
+test canvText-3.3 {TextCoords procedure} -setup {
+ .c create text 20 20 -tag test
+} -body {
+ .c coords test 0 xyz
+} -cleanup {
+ .c delete test
+} -returnCodes {error} -result {bad screen distance "xyz"}
+test canvText-3.4 {TextCoords procedure} -setup {
+ .c create text 20 20 -tag test
+} -body {
.c coords test 10 10
set result {}
foreach element [.c coords test] {
lappend result [format %.1f $element]
}
- set result
-} {10.0 10.0}
-test canvText-3.5 {TextCoords procedure} {
- list [catch {.c coords test 10} msg] $msg
-} {1 {wrong # coordinates: expected 2, got 1}}
-test canvText-3.6 {TextCoords procedure} {
- list [catch {.c coords test 10 10 10} msg] $msg
-} {1 {wrong # coordinates: expected 0 or 2, got 3}}
-
-test canvText-4.1 {ConfigureText procedure} {
- list [catch {.c itemconfig test -fill xyz} msg] $msg
-} {1 {unknown color name "xyz"}}
-test canvText-4.2 {ConfigureText procedure} {
+ return $result
+} -cleanup {
+ .c delete test
+} -result {10.0 10.0}
+test canvText-3.5 {TextCoords procedure} -setup {
+ .c create text 20 20 -tag test
+} -body {
+ .c coords test 10
+} -cleanup {
+ .c delete test
+} -returnCodes {error} -result {wrong # coordinates: expected 2, got 1}
+test canvText-3.6 {TextCoords procedure} -setup {
+ .c create text 20 20 -tag test
+} -body {
+ .c coords test 10 10 10
+} -cleanup {
+ .c delete test
+} -returnCodes {error} -result {wrong # coordinates: expected 0 or 2, got 3}
+
+
+test canvText-4.1 {ConfigureText procedure} -setup {
+ .c create text 20 20 -tag test
+} -body {
+ .c itemconfig test -fill xyz
+} -cleanup {
+ .c delete test
+} -returnCodes {error} -result {unknown color name "xyz"}
+test canvText-4.2 {ConfigureText procedure} -setup {
+ .c create text 20 20 -tag test
+} -body {
.c itemconfig test -fill blue
.c itemcget test -fill
-} {blue}
-test canvText-4.3 {ConfigureText procedure: construct font gcs} {
+} -cleanup {
+ .c delete test
+} -result {blue}
+test canvText-4.3 {ConfigureText procedure: construct font gcs} -setup {
+ .c create text 20 20 -tag test
+} -body {
.c itemconfig test -font "times 20" -fill black -stipple gray50
list [.c itemcget test -font] [.c itemcget test -fill] [.c itemcget test -stipple]
-} {{times 20} black gray50}
-test canvText-4.4 {ConfigureText procedure: construct cursor gc} {
+} -cleanup {
+ .c delete test
+} -result {{times 20} black gray50}
+test canvText-4.4 {ConfigureText procedure: construct cursor gc} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
.c itemconfig test -text "abcdefg"
.c select from test 2
.c select to test 4
@@ -133,9 +207,15 @@ test canvText-4.4 {ConfigureText procedure: construct cursor gc} {
.c config -selectbackground red
.c itemconfig test -just left
update
-} {}
-test canvText-4.5 {ConfigureText procedure: adjust selection} {
+} -cleanup {
+ .c delete test
+} -result {}
+test canvText-4.5 {ConfigureText procedure: adjust selection} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
set x {}
+} -body {
.c itemconfig test -text "abcdefghi"
.c select from test 2
.c select to test 6
@@ -154,89 +234,276 @@ test canvText-4.5 {ConfigureText procedure: adjust selection} {
lappend x [selection get]
.c dchars test 4 end
lappend x [selection get]
-} {cdefg 1 cdefg cd cdef cd}
-test canvText-4.6 {ConfigureText procedure: adjust cursor} {
+} -cleanup {
+ .c delete test
+} -result {cdefg 1 cdefg cd cdef cd}
+test canvText-4.6 {ConfigureText procedure: adjust cursor} -setup {
+ .c create text 20 20 -tag test
+} -body {
.c itemconfig test -text "abcdefghi"
- set x {}
.c icursor test 6
.c dchars test 4 end
.c index test insert
-} {4}
+} -cleanup {
+ .c delete test
+} -result {4}
+
-test canvText-5.1 {ConfigureText procedure: adjust cursor} {
+test canvText-5.1 {ConfigureText procedure: adjust cursor} -body {
.c create text 10 10 -tag x -fill blue -font "times 40" -stipple gray50 -text "xyz"
.c delete x
-} {}
+} -result {}
+
-test canvText-6.1 {ComputeTextBbox procedure} {fonts nonPortable} {
+test canvText-6.1 {ComputeTextBbox procedure} -constraints {
+ fonts
+} -setup {
+ .c delete test
+} -body {
+ set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+ set ay [font metrics $font -linespace]
+ set ax [font measure $font 0]
+
+ .c create text 0 0 -tag test
.c itemconfig test -font $font -text 0
- .c coords test 0 0
- set x {}
- lappend x [.c itemconfig test -anchor n; .c bbox test]
- lappend x [.c itemconfig test -anchor nw; .c bbox test]
- lappend x [.c itemconfig test -anchor w; .c bbox test]
- lappend x [.c itemconfig test -anchor sw; .c bbox test]
- lappend x [.c itemconfig test -anchor s; .c bbox test]
- lappend x [.c itemconfig test -anchor se; .c bbox test]
- lappend x [.c itemconfig test -anchor e; .c bbox test]
- lappend x [.c itemconfig test -anchor ne; .c bbox test]
- lappend x [.c itemconfig test -anchor center; .c bbox test]
-} "{[expr -$ax/2-1] 0 [expr $ax/2+1] $ay}\
-{-1 0 [expr $ax+1] $ay}\
-{-1 [expr -$ay/2] [expr $ax+1] [expr $ay/2]}\
-{-1 -$ay [expr $ax+1] 0}\
-{[expr -$ax/2-1] -$ay [expr $ax/2+1] 0}\
-{[expr -$ax-1] -$ay 1 0}\
-{[expr -$ax-1] [expr -$ay/2] 1 [expr $ay/2]}\
-{[expr -$ax-1] 0 1 $ay}\
-{[expr -$ax/2-1] [expr -$ay/2] [expr $ax/2+1] [expr $ay/2]}"
+ expr {[.c itemconfig test -anchor n; .c bbox test] \
+ eq "[expr -$ax/2-1] 0 [expr $ax/2+1] $ay"}
+} -cleanup {
+ .c delete test
+} -result 1
+test canvText-6.2 {ComputeTextBbox procedure} -constraints {
+ fonts
+} -setup {
+ .c delete test
+} -body {
+ set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+ set ay [font metrics $font -linespace]
+ set ax [font measure $font 0]
+
+ .c create text 0 0 -tag test
+ .c itemconfig test -font $font -text 0
+ expr {[.c itemconfig test -anchor nw; .c bbox test] \
+ eq "-1 0 [expr $ax+1] $ay"}
+} -cleanup {
+ .c delete test
+} -result 1
+test canvText-6.3 {ComputeTextBbox procedure} -constraints {
+ fonts
+} -setup {
+ .c delete test
+} -body {
+ set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+ set ay [font metrics $font -linespace]
+ set ax [font measure $font 0]
+
+ .c create text 0 0 -tag test
+ .c itemconfig test -font $font -text 0
+ expr {[.c itemconfig test -anchor w; .c bbox test] \
+ eq "-1 [expr -$ay/2] [expr $ax+1] [expr $ay/2]"}
+} -cleanup {
+ .c delete test
+} -result 1
+test canvText-6.4 {ComputeTextBbox procedure} -constraints {
+ fonts
+} -setup {
+ .c delete test
+} -body {
+ set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+ set ay [font metrics $font -linespace]
+ set ax [font measure $font 0]
+
+ .c create text 0 0 -tag test
+ .c itemconfig test -font $font -text 0
+ expr {[.c itemconfig test -anchor sw; .c bbox test] \
+ eq "-1 -$ay [expr $ax+1] 0"}
+} -cleanup {
+ .c delete test
+} -result 1
+test canvText-6.5 {ComputeTextBbox procedure} -constraints {
+ fonts
+} -setup {
+ .c delete test
+} -body {
+ set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+ set ay [font metrics $font -linespace]
+ set ax [font measure $font 0]
+
+ .c create text 0 0 -tag test
+ .c itemconfig test -font $font -text 0
+ expr {[.c itemconfig test -anchor s; .c bbox test] \
+ eq "[expr -$ax/2-1] -$ay [expr $ax/2+1] 0"}
+} -cleanup {
+ .c delete test
+} -result 1
+test canvText-6.6 {ComputeTextBbox procedure} -constraints {
+ fonts
+} -setup {
+ .c delete test
+} -body {
+ set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+ set ay [font metrics $font -linespace]
+ set ax [font measure $font 0]
+
+ .c create text 0 0 -tag test
+ .c itemconfig test -font $font -text 0
+ expr {[.c itemconfig test -anchor se; .c bbox test] \
+ eq "[expr -$ax-1] -$ay 1 0"}
+} -cleanup {
+ .c delete test
+} -result 1
+test canvText-6.7 {ComputeTextBbox procedure} -constraints {
+ fonts
+} -setup {
+ .c delete test
+} -body {
+ set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+ set ay [font metrics $font -linespace]
+ set ax [font measure $font 0]
+
+ .c create text 0 0 -tag test
+ .c itemconfig test -font $font -text 0
+ expr {[.c itemconfig test -anchor e; .c bbox test]\
+ eq "[expr -$ax-1] [expr -$ay/2] 1 [expr $ay/2]"}
+} -cleanup {
+ .c delete test
+} -result 1
+test canvText-6.8 {ComputeTextBbox procedure} -constraints {
+ fonts
+} -setup {
+ .c delete test
+} -body {
+ set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+ set ay [font metrics $font -linespace]
+ set ax [font measure $font 0]
+
+ .c create text 0 0 -tag test
+ .c itemconfig test -font $font -text 0
+ expr {[.c itemconfig test -anchor ne; .c bbox test] \
+ eq "[expr -$ax-1] 0 1 $ay"}
+} -cleanup {
+ .c delete test
+} -result 1
+test canvText-6.9 {ComputeTextBbox procedure} -constraints {
+ fonts
+} -setup {
+ .c delete test
+} -body {
+ set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
+ set ay [font metrics $font -linespace]
+ set ax [font measure $font 0]
+
+ .c create text 0 0 -tag test
+ .c itemconfig test -font $font -text 0
+ expr {[.c itemconfig test -anchor center; .c bbox test] \
+ eq "[expr -$ax/2-1] [expr -$ay/2] [expr $ax/2+1] [expr $ay/2]"}
+} -cleanup {
+ .c delete test
+} -result 1
+
+#.c delete test
+#.c create text 20 20 -tag test
+#focus -force .c
+#.c focus test
focus .c
.c focus test
.c itemconfig test -text "abcd\nefghi\njklmnopq"
-test canvText-7.0 {DisplayText procedure: stippling} {
+test canvText-7.1 {DisplayText procedure: stippling} -body {
+ .c create text 20 20 -tag test
.c itemconfig test -stipple gray50
update
.c itemconfig test -stipple {}
update
-} {}
-test canvText-7.2 {DisplayText procedure: draw selection} {
+} -cleanup {
+ .c delete test
+} -result {}
+test canvText-7.2 {DisplayText procedure: draw selection} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcd\nefghi\njklmnopq"
.c select from test 0
.c select to test end
update
selection get
-} "abcd\nefghi\njklmnopq"
-test canvText-7.3 {DisplayText procedure: selection} {
+} -cleanup {
+ .c delete test
+} -result "abcd\nefghi\njklmnopq"
+test canvText-7.3 {DisplayText procedure: selection} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcd\nefghi\njklmnopq"
.c select from test 0
.c select to test end
update
selection get
-} "abcd\nefghi\njklmnopq"
-test canvText-7.4 {DisplayText procedure: one line selection} {
+} -cleanup {
+ .c delete test
+} -result "abcd\nefghi\njklmnopq"
+test canvText-7.4 {DisplayText procedure: one line selection} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcd\nefghi\njklmnopq"
.c select from test 2
.c select to test 3
update
-} {}
-test canvText-7.5 {DisplayText procedure: multi-line selection} {
+} -cleanup {
+ .c delete test
+} -result {}
+test canvText-7.5 {DisplayText procedure: multi-line selection} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcd\nefghi\njklmnopq"
.c select from test 2
.c select to test 12
update
-} {}
-test canvText-7.6 {DisplayText procedure: draw cursor} {
+} -cleanup {
+ .c delete test
+} -result {}
+test canvText-7.6 {DisplayText procedure: draw cursor} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcd\nefghi\njklmnopq"
.c icursor test 3
update
-} {}
-test canvText-7.7 {DisplayText procedure: selected text different color} {
+} -cleanup {
+ .c delete test
+} -result {}
+test canvText-7.7 {DisplayText procedure: selected text different color} -setup {
+ .c create text 20 20 -tag test
+ .c itemconfig test -text "abcd\nefghi\njklmnopq"
+ focus .c
+ .c focus test
+} -body {
.c config -selectforeground blue
.c itemconfig test -anchor n
update
-} {}
-test canvText-7.8 {DisplayText procedure: not selected} {
+} -cleanup {
+ .c delete test
+} -result {}
+test canvText-7.8 {DisplayText procedure: not selected} -setup {
+ .c create text 20 20 -tag test
+ .c itemconfig test -text "abcd\nefghi\njklmnopq"
+ focus .c
+ .c focus test
+} -body {
.c select clear
update
-} {}
-test canvText-7.9 {DisplayText procedure: select end} {
- catch {destroy .t}
+} -cleanup {
+ .c delete test
+} -result {}
+test canvText-7.9 {DisplayText procedure: select end} -setup {
+ destroy .t
+} -body {
toplevel .t
wm geometry .t +0+0
canvas .t.c
@@ -248,244 +515,348 @@ test canvText-7.9 {DisplayText procedure: select end} {
update
#catch {destroy .t}
update
-} {}
-
-test canvText-8.1 {TextInsert procedure: 0 length insert} {
+} -cleanup {
+ destroy .t
+} -result {}
+
+test canvText-8.1 {TextInsert procedure: 0 length insert} -setup {
+ .c create text 20 20 -tag test
+ .c itemconfig test -text "abcd\nefghi\njklmnopq"
+ focus .c
+ .c focus test
+} -body {
.c insert test end {}
-} {}
-test canvText-8.2 {TextInsert procedure: before beginning/after end} {
+} -cleanup {
+ .c delete test
+} -result {}
+test canvText-8.2 {TextInsert procedure: before beginning/after end} -body {
# Can't test this because GetTextIndex filters out those numbers.
-} {}
-test canvText-8.3 {TextInsert procedure: inserting in a selected item} {
+} -result {}
+test canvText-8.3 {TextInsert procedure: inserting in a selected item} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
.c itemconfig test -text "abcdefg"
.c select from test 2
.c select to test 4
.c insert test 1 "xyz"
.c itemcget test -text
-} {axyzbcdefg}
-test canvText-8.4 {TextInsert procedure: inserting before selection} {
+} -result {axyzbcdefg}
+test canvText-8.4 {TextInsert procedure: inserting before selection} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
.c itemconfig test -text "abcdefg"
.c select from test 2
.c select to test 4
.c insert test 1 "xyz"
list [.c index test sel.first] [.c index test sel.last]
-} {5 7}
-test canvText-8.5 {TextInsert procedure: inserting in selection} {
+} -result {5 7}
+test canvText-8.5 {TextInsert procedure: inserting in selection} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
.c itemconfig test -text "abcdefg"
.c select from test 2
.c select to test 4
.c insert test 3 "xyz"
list [.c index test sel.first] [.c index test sel.last]
-} {2 7}
-test canvText-8.6 {TextInsert procedure: inserting after selection} {
+} -result {2 7}
+test canvText-8.6 {TextInsert procedure: inserting after selection} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
.c itemconfig test -text "abcdefg"
.c select from test 2
.c select to test 4
.c insert test 5 "xyz"
list [.c index test sel.first] [.c index test sel.last]
-} {2 4}
-test canvText-8.7 {TextInsert procedure: inserting in unselected item} {
+} -result {2 4}
+test canvText-8.7 {TextInsert procedure: inserting in unselected item} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
.c itemconfig test -text "abcdefg"
.c select clear
.c insert test 5 "xyz"
.c itemcget test -text
-} {abcdexyzfg}
-test canvText-8.8 {TextInsert procedure: inserting before cursor} {
+} -result {abcdexyzfg}
+test canvText-8.8 {TextInsert procedure: inserting before cursor} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
.c itemconfig test -text "abcdefg"
.c icursor test 3
.c insert test 2 "xyz"
.c index test insert
-} {6}
-test canvText-8.9 {TextInsert procedure: inserting after cursor} {
+} -result {6}
+test canvText-8.9 {TextInsert procedure: inserting after cursor} -setup {
+ .c create text 20 20 -tag test
+ focus .c
+ .c focus test
+} -body {
.c itemconfig test -text "abcdefg"
.c icursor test 3
.c insert test 4 "xyz"
.c index test insert
-} {3}
+} -result {3}
-test canvText-9.1 {TextInsert procedure: before beginning/after end} {
+# Item used in 9.* tests
+.c create text 20 20 -tag test
+test canvText-9.1 {TextInsert procedure: before beginning/after end} -body {
# Can't test this because GetTextIndex filters out those numbers.
-} {}
-test canvText-9.2 {TextInsert procedure: start > end} {
+} -result {}
+test canvText-9.2 {TextInsert procedure: start > end} -body {
.c itemconfig test -text "abcdefg"
.c dchars test 4 2
.c itemcget test -text
-} {abcdefg}
-test canvText-9.3 {TextInsert procedure: deleting from a selected item} {
+} -result {abcdefg}
+test canvText-9.3 {TextInsert procedure: deleting from a selected item} -body {
.c itemconfig test -text "abcdefg"
.c select from test 2
.c select to test 4
.c dchars test 3 5
.c itemcget test -text
-} {abcg}
-test canvText-9.4 {TextInsert procedure: deleting before start} {
+} -result {abcg}
+test canvText-9.4 {TextInsert procedure: deleting before start} -body {
.c itemconfig test -text "abcdefghijk"
.c select from test 4
.c select to test 8
.c dchars test 1 1
list [.c index test sel.first] [.c index test sel.last]
-} {3 7}
-test canvText-9.5 {TextInsert procedure: keep start > first char deleted} {
+} -result {3 7}
+test canvText-9.5 {TextInsert procedure: keep start > first char deleted} -body {
.c itemconfig test -text "abcdefghijk"
.c select from test 4
.c select to test 8
.c dchars test 2 6
list [.c index test sel.first] [.c index test sel.last]
-} {2 3}
-test canvText-9.6 {TextInsert procedure: deleting inside selection} {
+} -result {2 3}
+test canvText-9.6 {TextInsert procedure: deleting inside selection} -body {
.c itemconfig test -text "abcdefghijk"
.c select from test 4
.c select to test 8
.c dchars test 6 6
list [.c index test sel.first] [.c index test sel.last]
-} {4 7}
-test canvText-9.7 {TextInsert procedure: keep end > first char deleted} {
+} -result {4 7}
+test canvText-9.7 {TextInsert procedure: keep end > first char deleted} -body {
.c itemconfig test -text "abcdefghijk"
.c select from test 4
.c select to test 8
.c dchars test 6 10
list [.c index test sel.first] [.c index test sel.last]
-} {4 5}
-test canvText-9.8 {TextInsert procedure: selectFirst > selectLast: deselect} {
+} -result {4 5}
+test canvText-9.8 {TextInsert procedure: selectFirst > selectLast: deselect} -body {
.c itemconfig test -text "abcdefghijk"
.c select from test 4
.c select to test 8
.c dchars test 3 10
- list [catch {.c index test sel.first} msg] $msg
-} {1 {selection isn't in item}}
-test canvText-9.9 {TextInsert procedure: selectFirst <= selectLast} {
+ .c index test sel.first
+} -returnCodes {error} -result {selection isn't in item}
+test canvText-9.9 {TextInsert procedure: selectFirst <= selectLast} -body {
.c itemconfig test -text "abcdefghijk"
.c select from test 4
.c select to test 8
.c dchars test 4 7
list [.c index test sel.first] [.c index test sel.last]
-} {4 4}
-test canvText-9.10 {TextInsert procedure: move anchor} {
+} -result {4 4}
+test canvText-9.10 {TextInsert procedure: move anchor} -body {
.c itemconfig test -text "abcdefghijk"
.c select from test 6
.c select to test 8
.c dchars test 2 4
.c select to test 1
list [.c index test sel.first] [.c index test sel.last]
-} {1 2}
-test canvText-9.11 {TextInsert procedure: keep anchor >= first} {
+} -result {1 2}
+test canvText-9.11 {TextInsert procedure: keep anchor >= first} -body {
.c itemconfig test -text "abcdefghijk"
.c select from test 6
.c select to test 8
.c dchars test 5 7
.c select to test 1
list [.c index test sel.first] [.c index test sel.last]
-} {1 4}
-test canvText-9.12 {TextInsert procedure: anchor doesn't move} {
+} -result {1 4}
+test canvText-9.12 {TextInsert procedure: anchor doesn't move} -body {
.c itemconfig test -text "abcdefghijk"
.c select from test 2
.c select to test 5
.c dchars test 6 8
.c select to test 8
list [.c index test sel.first] [.c index test sel.last]
-} {2 8}
-test canvText-9.13 {TextInsert procedure: move cursor} {
+} -result {2 8}
+test canvText-9.13 {TextInsert procedure: move cursor} -body {
.c itemconfig test -text "abcdefghijk"
.c icursor test 6
.c dchars test 2 4
.c index test insert
-} {3}
-test canvText-9.14 {TextInsert procedure: keep cursor >= first} {
+} -result {3}
+test canvText-9.14 {TextInsert procedure: keep cursor >= first} -body {
.c itemconfig test -text "abcdefghijk"
.c icursor test 6
.c dchars test 2 10
.c index test insert
-} {2}
-test canvText-9.15 {TextInsert procedure: cursor doesn't move} {
+} -result {2}
+test canvText-9.15 {TextInsert procedure: cursor doesn't move} -body {
.c itemconfig test -text "abcdefghijk"
.c icursor test 5
.c dchars test 7 9
.c index test insert
-} {5}
+} -result {5}
+.c delete test
+
-test canvText-10.1 {TextToPoint procedure} {
- .c coords test 0 0
+test canvText-10.1 {TextToPoint procedure} -body {
+ .c create text 0 0 -tag test
.c itemconfig test -text 0 -anchor center
.c index test @0,0
-} {0}
+} -cleanup {
+ .c delete test
+} -result {0}
+
-test canvText-11.1 {TextToArea procedure} {
- .c coords test 0 0
+test canvText-11.1 {TextToArea procedure} -setup {
+ .c create text 0 0 -tag test
+ focus .c
+ .c focus test
+} -body {
.c itemconfig test -text 0 -anchor center
- .c find overlapping 0 0 1 1
-} [.c find withtag test]
-test canvText-11.2 {TextToArea procedure} {
- .c coords test 0 0
+ set res1 [.c find overlapping 0 0 1 1]
+ set res2 [.c find withtag test]
+ expr {$res1 eq $res2}
+} -cleanup {
+ .c delete test
+} -result 1
+test canvText-11.2 {TextToArea procedure} -setup {
+ .c create text 0 0 -tag test
+ focus .c
+ .c focus test
+} -body {
.c itemconfig test -text 0 -anchor center
.c find overlapping 1000 1000 1001 1001
-} {}
+} -cleanup {
+ .c delete test
+} -result {}
-test canvText-12.1 {ScaleText procedure} {
- .c coords test 100 100
+
+test canvText-12.1 {ScaleText procedure} -body {
+ .c create text 100 100 -tag test
.c scale all 50 50 2 2
.c coords test
-} {150.0 150.0}
+} -cleanup {
+ .c delete test
+} -result {150.0 150.0}
+
-test canvText-13.1 {TranslateText procedure} {
- .c coords test 100 100
+test canvText-13.1 {TranslateText procedure} -body {
+ .c create text 100 100 -tag test
.c move all 10 10
.c coords test
-} {110.0 110.0}
-
-.c itemconfig test -text "abcdefghijklmno" -anchor nw
-.c select from test 5
-.c select to test 8
-.c icursor test 12
-.c coords test 0 0
-test canvText-14.1 {GetTextIndex procedure} {
+} -cleanup {
+ .c delete test
+} -result {110.0 110.0}
+
+
+test canvText-14.1 {GetTextIndex procedure} -setup {
+ .c create text 0 0 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcdefghijklmno" -anchor nw
+ .c select from test 5
+ .c select to test 8
+ .c icursor test 12
+ .c coords test 0 0
+
list [.c index test end] [.c index test insert] \
[.c index test sel.first] [.c index test sel.last] \
[.c index test @0,0] \
[.c index test -1] [.c index test 10] [.c index test 100]
-} {15 12 5 8 0 0 10 15}
-test canvText-14.2 {GetTextIndex procedure: select error} {
+} -cleanup {
+ .c delete test
+} -result {15 12 5 8 0 0 10 15}
+test canvText-14.2 {GetTextIndex procedure: select error} -setup {
+ .c create text 0 0 -tag test
+ focus .c
+ .c focus test
+} -body {
.c select clear
- list [catch {.c index test sel.first} msg] $msg
-} {1 {selection isn't in item}}
-test canvText-14.3 {GetTextIndex procedure: select error} {
+ .c index test sel.first
+} -cleanup {
+ .c delete test
+} -returnCodes {error} -result {selection isn't in item}
+test canvText-14.3 {GetTextIndex procedure: select error} -setup {
+ .c create text 0 0 -tag test
+ focus .c
+ .c focus test
+} -body {
.c select clear
- list [catch {.c index test sel.last} msg] $msg
-} {1 {selection isn't in item}}
-test canvText-14.4 {GetTextIndex procedure: select error} {
+ .c index test sel.last
+} -cleanup {
+ .c delete test
+} -returnCodes {error} -result {selection isn't in item}
+test canvText-14.4 {GetTextIndex procedure: select error} -setup {
+ .c create text 0 0 -tag test
+ focus .c
+ .c focus test
+} -body {
.c select clear
- list [catch {.c index test sel.} msg] $msg
-} {1 {bad index "sel."}}
-test canvText-14.5 {GetTextIndex procedure: bad int or unknown index} {
- list [catch {.c index test xyz} msg] $msg
-} {1 {bad index "xyz"}}
-
-test canvText-15.1 {SetTextCursor procedure} {
+ .c index test sel.
+} -cleanup {
+ .c delete test
+} -returnCodes {error} -result {bad index "sel."}
+test canvText-14.5 {GetTextIndex procedure: bad int or unknown index} -setup {
+ .c create text 0 0 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c index test xyz
+} -cleanup {
+ .c delete test
+} -returnCodes {error} -result {bad index "xyz"}
+
+
+test canvText-15.1 {SetTextCursor procedure} -setup {
+ .c create text 0 0 -tag test
+ focus .c
+ .c focus test
+} -body {
+ .c itemconfig test -text "abcdefghijklmno" -anchor nw
.c itemconfig -text "abcdefg"
.c icursor test 3
.c index test insert
-} {3}
+} -cleanup {
+ .c delete test
+} -result {3}
-test canvText-16.1 {GetSelText procedure} {
+
+test canvText-16.1 {GetSelText procedure} -setup {
+ .c create text 0 0 -tag test
+ focus .c
+ .c focus test
+} -body {
.c itemconfig test -text "abcdefghijklmno" -anchor nw
.c select from test 5
.c select to test 8
selection get
-} {fghi}
+} -cleanup {
+ .c delete test
+} -result {fghi}
-set font {Courier 12 italic}
-set ax [font measure $font 0]
-set ay [font metrics $font -linespace]
-test canvText-17.1 {TextToPostscript procedure} {
+test canvText-17.1 {TextToPostscript procedure} -setup {
.c delete all
- .c config -height 300 -highlightthickness 0 -bd 0
- update
- .c create text 100 100 -tags test
- .c itemconfig test -font $font -text "00000000" -width [expr 3*$ax]
- .c itemconfig test -anchor n -fill black
- set x [.c postscript]
- set x [string range $x [string first "/Courier-Oblique" $x] end]
-} "/Courier-Oblique findfont [font actual $font -size] scalefont ISOEncode setfont
+} -body {
+ set font {Courier 12 italic}
+ set ax [font measure $font 0]
+ set ay [font metrics $font -linespace]
+
+ set result "/Courier-Oblique findfont [font actual $font -size] scalefont ISOEncode setfont
0.000 0.000 0.000 setrgbcolor AdjustColor
100 200 \[
\[(000)\]
@@ -499,23 +870,35 @@ restore showpage
end
%%EOF
"
+ .c config -height 300 -highlightthickness 0 -bd 0
+ update
+ .c create text 100 100 -tags test
+ .c itemconfig test -font $font -text "00000000" -width [expr 3*$ax]
+ .c itemconfig test -anchor n -fill black
+ set x [.c postscript]
+ set x [string range $x [string first "/Courier-Oblique" $x] end]
+ expr {$x eq $result}
+} -result 1
-test canvText-18.1 {bug fix 2525, find enclosed on text with newlines} {
- catch {destroy .c}
- canvas .c
- pack .c
- .c delete all
+test canvText-18.1 {bug fix 2525, find enclosed on text with newlines} -setup {
+ destroy .c
+} -body {
+ pack [canvas .c]
.c create text 100 100 -text Hello\n -anchor nw
set bbox [.c bbox 1]
set x2 [lindex $bbox 2]
set y2 [lindex $bbox 3]
incr y2
update
- .c find enclosed 99 99 [expr $x2 + $i] [expr $y2 + 1]
-} 1
+ .c find enclosed 99 99 [expr $x2 + 1] [expr $y2 + 1]
+} -cleanup {
+ destroy .c
+} -result 1
+
-test canvText-19.1 {patch 1006286, leading space caused wrap under Win32} {
- catch {destroy .c}
+test canvText-19.1 {patch 1006286, leading space caused wrap under Win32} -setup {
+ destroy .c
+} -body {
set c [canvas .c -bg black -width 964]
pack $c
$c delete all
@@ -565,10 +948,15 @@ test canvText-19.1 {patch 1006286, leading space caused wrap under Win32} {
lappend results [$c index tbox1 @$x,$y1]
lappend results [$c index tbox2 @$x,$y2]
- set results
-} {{Yeah } Yeah- 4 4}
+ return $results
+} -cleanup {
+ destroy .c
+} -result {{Yeah } Yeah- 4 4}
# cleanup
cleanupTests
return
+
+
+
diff --git a/tests/obj.test b/tests/obj.test
index 3112f8b..3cd7230 100644
--- a/tests/obj.test
+++ b/tests/obj.test
@@ -5,28 +5,26 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: obj.test,v 1.5 2004/05/23 17:34:49 dkf Exp $
+# RCS: @(#) $Id: obj.test,v 1.6 2008/08/11 21:33:17 aniap Exp $
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
-test obj-1.1 {TkGetPixelsFromObj} {
-} {}
+test obj-1.1 {TkGetPixelsFromObj} -body {
+} -result {}
-test obj-2.1 {FreePixelInternalRep} {
-} {}
+test obj-2.1 {FreePixelInternalRep} -body {
+} -result {}
-test obj-3.1 {DupPixelInternalRep} {
-} {}
+test obj-3.1 {DupPixelInternalRep} -body {
+} -result {}
-test obj-4.1 {SetPixelFromAny} {
-} {}
+test obj-4.1 {SetPixelFromAny} -body {
+} -result {}
-
-deleteWindows
-
# cleanup
cleanupTests
return