1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
|
# This file is a Tcl script to test out the procedures in tkCanvas.c,
# which implements generic code for canvases. It is organized in the
# standard fashion for Tcl tests.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: canvas.test,v 1.4 1998/10/13 18:13:07 rjohnson Exp $
if {[info procs test] != "test"} {
source defs
}
foreach i [winfo children .] {
destroy $i
}
wm geometry . {}
raise .
# XXX - This test file is woefully incomplete. At present, only a
# few of the features are tested.
canvas .c
pack .c
update
set i 1
foreach test {
{-background #ff0000 #ff0000 non-existent
{unknown color name "non-existent"}}
{-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}}
{-bd 4 4 badValue {bad screen distance "badValue"}}
{-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
{-closeenough 24 24.0 bogus {expected floating-point number but got "bogus"}}
{-confine true 1 silly {expected boolean value but got "silly"}}
{-cursor arrow arrow badValue {bad cursor spec "badValue"}}
{-height 2.1 2 x42 {bad screen distance "x42"}}
{-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}}
{-highlightcolor #110022 #110022 bogus {unknown color name "bogus"}}
{-highlightthickness 18 18 badValue {bad screen distance "badValue"}}
{-insertbackground #110022 #110022 bogus {unknown color name "bogus"}}
{-insertborderwidth 1.3 1 2.6x {bad screen distance "2.6x"}}
{-insertofftime 100 100 3.2 {expected integer but got "3.2"}}
{-insertontime 100 100 3.2 {expected integer but got "3.2"}}
{-insertwidth 1.3 1 6x {bad screen distance "6x"}}
{-relief groove groove 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}}
{-selectbackground #110022 #110022 bogus {unknown color name "bogus"}}
{-selectborderwidth 1.3 1 badValue {bad screen distance "badValue"}}
{-selectforeground #654321 #654321 bogus {unknown color name "bogus"}}
{-takefocus "any string" "any string" {} {}}
{-width 402 402 xyz {bad screen distance "xyz"}}
{-xscrollcommand {Some command} {Some command} {} {}}
{-yscrollcommand {Another command} {Another command} {} {}}
} {
set name [lindex $test 0]
test canvas-1.$i {configuration options} {
.c configure $name [lindex $test 1]
lindex [.c configure $name] 4
} [lindex $test 2]
incr i
if {[lindex $test 3] != ""} {
test canvas-1.$i {configuration options} {
list [catch {.c configure $name [lindex $test 3]} msg] $msg
} [list 1 [lindex $test 4]]
}
.c configure $name [lindex [.c configure $name] 3]
incr i
}
catch {destroy .c}
canvas .c -width 60 -height 40 -scrollregion {0 0 200 150} -bd 0 \
-highlightthickness 0
pack .c
update
test canvas-2.1 {CanvasWidgetCmd, xview option} {
.c configure -xscrollincrement 40 -yscrollincrement 5
.c xview moveto 0
update
set x [list [.c xview]]
.c xview scroll 2 units
update
lappend x [.c xview]
} {{0 0.3} {0.4 0.7}}
test canvas-2.2 {CanvasWidgetCmd, xview option} {nonPortable} {
# This test gives slightly different results on platforms such
# as NetBSD. I don't know why...
.c configure -xscrollincrement 0 -yscrollincrement 5
.c xview moveto 0.6
update
set x [list [.c xview]]
.c xview scroll 2 units
update
lappend x [.c xview]
} {{0.6 0.9} {0.66 0.96}}
catch {destroy .c}
canvas .c -width 60 -height 40 -scrollregion {0 0 200 80} \
-borderwidth 0 -highlightthickness 0
pack .c
update
test canvas-3.1 {CanvasWidgetCmd, yview option} {
.c configure -xscrollincrement 40 -yscrollincrement 5
.c yview moveto 0
update
set x [list [.c yview]]
.c yview scroll 3 units
update
lappend x [.c yview]
} {{0 0.5} {0.1875 0.6875}}
test canvas-3.2 {CanvasWidgetCmd, yview option} {
.c configure -xscrollincrement 40 -yscrollincrement 0
.c yview moveto 0
update
set x [list [.c yview]]
.c yview scroll 2 units
update
lappend x [.c yview]
} {{0 0.5} {0.1 0.6}}
test canvas-4.1 {ButtonEventProc procedure} {
eval destroy [winfo children .]
canvas .c1 -bg #543210
rename .c1 .c2
set x {}
lappend x [winfo children .]
lappend x [.c2 cget -bg]
destroy .c1
lappend x [info command .c*] [winfo children .]
} {.c1 #543210 {} {}}
test canvas-5.1 {ButtonCmdDeletedProc procedure} {
eval destroy [winfo children .]
canvas .c1
rename .c1 {}
list [info command .c*] [winfo children .]
} {{} {}}
catch {destroy .c}
canvas .c -width 100 -height 50 -scrollregion {-200 -100 305 102} \
-borderwidth 2 -highlightthickness 3
pack .c
update
test canvas-6.1 {CanvasSetOrigin procedure} {
.c configure -xscrollincrement 0 -yscrollincrement 0
.c xview moveto 0
.c yview moveto 0
update
list [.c canvasx 0] [.c canvasy 0]
} {-205.0 -105.0}
test canvas-6.2 {CanvasSetOrigin procedure} {
.c configure -xscrollincrement 20 -yscrollincrement 10
set x ""
foreach i {.08 .10 .48 .50} {
.c xview moveto $i
update
lappend x [.c canvasx 0]
}
set x
} {-165.0 -145.0 35.0 55.0}
test canvas-6.3 {CanvasSetOrigin procedure} {
.c configure -xscrollincrement 20 -yscrollincrement 10
set x ""
foreach i {.06 .08 .70 .72} {
.c yview moveto $i
update
lappend x [.c canvasy 0]
}
set x
} {-95.0 -85.0 35.0 45.0}
test canvas-6.4 {CanvasSetOrigin procedure} {
.c configure -xscrollincrement 20 -yscrollincrement 10
.c xview moveto 1.0
.c canvasx 0
} {215.0}
test canvas-6.5 {CanvasSetOrigin procedure} {
.c configure -xscrollincrement 20 -yscrollincrement 10
.c yview moveto 1.0
.c canvasy 0
} {55.0}
set l [interp hidden]
eval destroy [winfo children .]
test canvas-7.1 {canvas widget vs hidden commands} {
catch {destroy .c}
canvas .c
interp hide {} .c
destroy .c
list [winfo children .] [interp hidden]
} [list {} $l]
test canvas-8.1 {canvas arc bbox} {
catch {destroy .c}
canvas .c
.c create arc -100 10 100 210 -start 10 -extent 50 -style arc -tags arc1
set arcBox [.c bbox arc1]
.c create arc 100 10 300 210 -start 10 -extent 50 -style chord -tags arc2
set coordBox [.c bbox arc2]
.c create arc 300 10 500 210 -start 10 -extent 50 -style pieslice -tags arc3
set pieBox [.c bbox arc3]
list $arcBox $coordBox $pieBox
} {{48 21 100 94} {248 21 300 94} {398 21 500 112}}
test canvas-9.1 {canvas id creation and deletion} {
# With Tk 8.0.4 the ids are now stored in a hash table. You
# can use this test as a performance test with older versions
# by changing the value of size.
set size 15
catch {destroy .c}
set c [canvas .c]
for {set i 0} {$i < $size} {incr i} {
set x [expr {-10 + 3*$i}]
for {set j 0; set y -10} {$j < 10} {incr j; incr y 3} {
$c create rect ${x}c ${y}c [expr $x+2]c [expr $y+2]c \
-outline black -fill blue -tags rect
$c create text [expr $x+1]c [expr $y+1]c -text "$i,$j" \
-anchor center -tags text
}
}
# The actual bench mark - this code also exercises all the hash
# table changes.
set time [lindex [time {
foreach id [$c find withtag all] {
$c lower $id
$c raise $id
$c find withtag $id
$c bind <Return> $id {}
$c delete $id
}
}] 0]
set x ""
} {}
|
