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
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
|
# textImage.test -- test images embedded in text widgets
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
# RCS: @(#) $Id: textImage.test,v 1.5 2002/07/13 20:28:35 dgp Exp $
package require tcltest 2.1
namespace import -force tcltest::configure
namespace import -force tcltest::testsDirectory
configure -testdir [file join [pwd] [file dirname [info script]]]
configure -loadfile [file join [testsDirectory] constraints.tcl]
tcltest::loadTestedCommands
# One time setup. Create a font to insure the tests are font metric invariant.
catch {destroy .t}
font create test_font -family courier -size 14
text .t -font test_font
destroy .t
test textImage-1.1 {basic argument checking} {
catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
list [catch {.t image} msg] $msg
} {1 {wrong # args: should be ".t image option ?arg arg ...?"}}
test textImage-1.2 {basic argument checking} {
catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
list [catch {.t image c} msg] $msg
} {1 {bad image option "c": must be cget, configure, create, or names}}
test textImage-1.3 {cget argument checking} {
catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
list [catch {.t image cget} msg] $msg
} {1 {wrong # args: should be ".t image cget index option"}}
test textImage-1.4 {cget argument checking} {
catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
list [catch {.t image cget blurf -flurp} msg] $msg
} {1 {bad text index "blurf"}}
test textImage-1.5 {cget argument checking} {
catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
list [catch {.t image cget 1.1 -flurp} msg] $msg
} {1 {no embedded image at index "1.1"}}
test textImage-1.6 {configure argument checking} {
catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
list [catch {.t image configure } msg] $msg
} {1 {wrong # args: should be ".t image configure index ?option value ...?"}}
test textImage-1.7 {configure argument checking} {
catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
list [catch {.t image configure blurf } msg] $msg
} {1 {bad text index "blurf"}}
test textImage-1.8 {configure argument checking} {
catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
list [catch {.t image configure 1.1 } msg] $msg
} {1 {no embedded image at index "1.1"}}
test textImage-1.9 {create argument checking} {
catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
list [catch {.t image create} msg] $msg
} {1 {wrong # args: should be ".t image create index ?option value ...?"}}
test textImage-1.10 {create argument checking} {
catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
list [catch {.t image create blurf } msg] $msg
} {1 {bad text index "blurf"}}
test textImage-1.11 {basic argument checking} {
catch {
image create photo small -width 5 -height 5
small put red -to 0 0 4 4
}
catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
list [catch {.t image create 1000.1000 -image small} msg] $msg
} {0 small}
test textImage-1.12 {names argument checking} {
catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
list [catch {.t image names dates places} msg] $msg
} {1 {wrong # args: should be ".t image names"}}
test textImage-1.13 {names argument checking} {
catch {
image create photo small -width 5 -height 5
small put red -to 0 0 4 4
}
catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
set result ""
lappend result [.t image names]
.t image create insert -image small
lappend result [.t image names]
.t image create insert -image small
lappend result [.t image names]
.t image create insert -image small -name little
lappend result [.t image names]
} {{} small {small#1 small} {small#1 small little}}
test textImage-1.14 {basic argument checking} {
catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
list [catch {.t image huh} msg] $msg
} {1 {bad image option "huh": must be cget, configure, create, or names}}
test textImage-1.15 {align argument checking} {
catch {
image create photo small -width 5 -height 5
small put red -to 0 0 4 4
}
catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
list [catch {.t image create end -image small -align wrong} msg] $msg
} {1 {bad alignment "wrong": must be baseline, bottom, center, or top}}
test textImage-1.16 {configure} {
catch {
image create photo small -width 5 -height 5
small put red -to 0 0 4 4
}
catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image create end -image small
.t image configure small
} {{-align {} {} center center} {-padx {} {} 0 0} {-pady {} {} 0 0} {-image {} {} {} small} {-name {} {} {} {}}}
test textImage-1.17 {basic cget options} {
catch {
image create photo small -width 5 -height 5
small put red -to 0 0 4 4
}
catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image create end -image small
set result ""
foreach i {align padx pady image name} {
lappend result $i:[.t image cget small -$i]
}
set result
} {align:center padx:0 pady:0 image:small name:}
test textImage-1.18 {basic configure options} {
catch {
image create photo small -width 5 -height 5
small put red -to 0 0 4 4
image create photo large -width 50 -height 50
large put green -to 0 0 50 50
}
catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image create end -image small
set result ""
foreach {option value} {align top padx 5 pady 7 image large name none} {
.t image configure small -$option $value
}
update
.t image configure small
} {{-align {} {} center top} {-padx {} {} 0 5} {-pady {} {} 0 7} {-image {} {} {} large} {-name {} {} {} none}}
test textImage-1.19 {basic image naming} {
catch {
image create photo small -width 5 -height 5
small put red -to 0 0 4 4
}
catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image create end -image small
.t image create end -image small -name small
.t image create end -image small -name small#6342
.t image create end -image small -name small
lsort [.t image names]
} {small small#1 small#6342 small#6343}
test textImage-2.1 {debug} {
catch {
image create photo small -width 5 -height 5
small put red -to 0 0 4 4
}
catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t debug 1
.t insert end front
.t image create end -image small
.t insert end back
.t delete small
.t image names
.t debug 0
} {}
test textImage-3.1 {image change propagation} {
catch {
image create photo vary -width 5 -height 5
small put red -to 0 0 4 4
}
catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image create end -image vary -align top
update
set result ""
lappend result base:[.t bbox vary]
foreach i {10 20 40} {
vary configure -width $i -height $i
update
lappend result $i:[.t bbox vary]
}
set result
} {{base:0 0 5 5} {10:0 0 10 10} {20:0 0 20 20} {40:0 0 40 40}}
test textImage-3.2 {delayed image management} {
catch {
image create photo small -width 5 -height 5
small put red -to 0 0 4 4
}
catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image create end -name test
update
set result ""
lappend result [.t bbox test]
.t image configure test -image small -align top
update
lappend result [.t bbox test]
} {{} {0 0 5 5}}
# some temporary random tests
test textImage-4.1 {alignment checking - except baseline} {
catch {
image create photo small -width 5 -height 5
small put red -to 0 0 4 4
image create photo large -width 50 -height 50
large put green -to 0 0 50 50
}
catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image create end -image large
.t image create end -image small
.t insert end test
update
set result ""
lappend result default:[.t bbox small]
foreach i {top bottom center} {
.t image configure small -align $i
update
lappend result [.t image cget small -align]:[.t bbox small]
}
set result
} {{default:50 22 5 5} {top:50 0 5 5} {bottom:50 45 5 5} {center:50 22 5 5}}
test textImage-4.2 {alignment checking - baseline} {
catch {
image create photo small -width 5 -height 5
small put red -to 0 0 4 4
image create photo large -width 50 -height 50
large put green -to 0 0 50 50
}
catch {destroy .t}
font create test_font2 -size 5
text .t -font test_font2 -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image create end -image large
.t image create end -image small -align baseline
.t insert end test
set result ""
foreach size {10 15 20 30} {
font configure test_font2 -size $size
array set Metrics [font metrics test_font2]
update
foreach {x y w h} [.t bbox small] {}
set norm [expr {
(([image height large] - $Metrics(-linespace))/2
+ $Metrics(-ascent) - [image height small] - $y)
}]
lappend result "$size $norm"
}
font delete test_font2
unset Metrics
set result
} {{10 0} {15 0} {20 0} {30 0}}
test textImage-4.3 {alignment and padding checking} {fonts} {
catch {
image create photo small -width 5 -height 5
small put red -to 0 0 4 4
image create photo large -width 50 -height 50
large put green -to 0 0 50 50
}
catch {destroy .t}
text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
pack .t
.t image create end -image large
.t image create end -image small -padx 5 -pady 10
.t insert end test
update
set result ""
lappend result default:[.t bbox small]
foreach i {top bottom center baseline} {
.t image configure small -align $i
update
lappend result $i:[.t bbox small]
}
set result
} {{default:55 22 5 5} {top:55 10 5 5} {bottom:55 35 5 5} {center:55 22 5 5} {baseline:55 22 5 5}}
# cleanup
catch {destroy .t}
foreach image [image names] {image delete $image}
font delete test_font
# cleanup
::tcltest::cleanupTests
return
|
