summaryrefslogtreecommitdiffstats
path: root/tests/canvText.test
blob: b121c25889316f52082dc31efefd81cb9d996738 (plain)
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
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
# This file is a Tcl script to test out the procedures in tkCanvText.c,
# which implement canvas "text" items.  It is organized in the standard
# fashion for Tcl tests.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# SCCS: @(#) canvText.test 1.8 97/06/24 13:34:16

if {"[info procs test]" != "test"} {
    source defs
}

foreach i [winfo children .] {
    destroy $i
}
wm geometry . {}
raise .

canvas .c -width 400 -height 300 -bd 2 -relief sunken
pack .c
update

set i 1
.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"}}
    {-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 {} {}}
    {-width 6 6 xyz {bad screen distance "xyz"}}
} {
    set name [lindex $test 0]
    test canvText-1.$i {configuration options} {
	.c itemconfigure test $name [lindex $test 1]
	list [lindex [.c itemconfigure test $name] 4] [.c itemcget test $name]
    } [list [lindex $test 2] [lindex $test 2]]
    incr i
    if {[lindex $test 3] != ""} {
	test canvText-1.$i {configuration options} {
	    list [catch {.c itemconfigure test $name [lindex $test 3]} msg] $msg
	} [list 1 [lindex $test 4]]
    }
    incr i
}
test canvText-1.$i {configuration options} {
    .c itemconfigure test -tags {test xyz}
    .c itemcget xyz -tags
} {test xyz}

.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 x y ?options?"}}
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} {
    .c create text 0 0 -tags x
    set x [.c coords x]
    .c delete x
    set x
} {0.0 0.0}

focus -force .c
.c focus test
.c coords test 0 0
update

test canvText-3.1 {TextCoords procedure} {
    .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} {
    .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 0 or 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} {
    .c itemconfig test -fill blue
    .c itemcget test -fill
} {blue}
test canvText-4.3 {ConfigureText procedure: construct font gcs} {
    .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} {
    .c itemconfig test -text "abcdefg"
    .c select from test 2
    .c select to test 4
    .c icursor test 3

    # Both black -> cursor becomes white.
    .c config -insertbackground black
    .c config -selectbackground black
    .c itemconfig test -just left
    update

    # Both same color (and not black) -> cursor becomes black.
    .c config -insertbackground red
    .c config -selectbackground red
    .c itemconfig test -just left
    update
} {}
test canvText-4.5 {ConfigureText procedure: adjust selection} {
    set x {}
    .c itemconfig test -text "abcdefghi"
    .c select from test 2
    .c select to test 6
    lappend x [selection get]
    .c dchars test 1 end
    lappend x [catch {selection get}]
    .c insert test end "bcdefghi"
    .c select from test 2
    .c select to test 6
    lappend x [selection get]
    .c dchars test 4 end
    lappend x [selection get]
    .c insert test end "efghi"
    .c select from test 6
    .c select to test 2
    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} {
    .c itemconfig test -text "abcdefghi"
    set x {}
    .c icursor test 6
    .c dchars test 4 end
    .c index test insert
} {4}

test canvText-5.1 {ConfigureText procedure: adjust cursor} {
    .c create text 10 10 -tag x -fill blue -font "times 40" -stipple gray50 -text "xyz"
    .c delete x
} {}

test canvText-6.1 {ComputeTextBbox procedure} {fonts} {
    .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]}"

focus .c
.c focus test
.c itemconfig test -text "abcd\nefghi\njklmnopq"
test canvText-7.1 {DisplayText procedure: stippling} {
    .c itemconfig test -stipple gray50
    update
    .c itemconfig test -stipple {}
    update
} {}
test canvText-7.2 {DisplayText procedure: draw selection} {
    .c select from test 0
    .c select to test end
    update
    selection get
} "abcd\nefghi\njklmnopq"
test canvText-7.3 {DisplayText procedure: selection} {
    .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} {
    .c select from test 2
    .c select to test 3
    update
} {}
test canvText-7.5 {DisplayText procedure: multi-line selection} {
    .c select from test 2
    .c select to test 12
    update
} {}
test canvText-7.6 {DisplayText procedure: draw cursor} {
    .c icursor test 3
    update
} {}
test canvText-7.7 {DisplayText procedure: selected text different color} {
    .c config -selectforeground blue
    .c itemconfig test -anchor n
    update
} {}
test canvText-7.8 {DisplayText procedure: not selected} {
    .c select clear
    update
} {}

test canvText-8.1 {TextInsert procedure: 0 length insert} {
    .c insert test end {}
} {}
test canvText-8.2 {TextInsert procedure: before beginning/after end} {
    # Can't test this because GetTextIndex filters out those numbers.
} {}
test canvText-8.3 {TextInsert procedure: inserting in a selected item} {
    .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} {
    .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} {
    .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} {
    .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} {
    .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} {
    .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} {
    .c itemconfig test -text "abcdefg"
    .c icursor test 3
    .c insert test 4 "xyz"
    .c index test insert
} {3}

test canvText-9.1 {TextInsert procedure: before beginning/after end} {
    # Can't test this because GetTextIndex filters out those numbers.
} {}
test canvText-9.2 {TextInsert procedure: start > end} {
    .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} {
    .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} {
    .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} {
    .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} {
    .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} {
    .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} {
    .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 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} {
    .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} {
    .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} {
    .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} {
    .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} {
    .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} {
    .c itemconfig test -text "abcdefghijk"
    .c icursor test 5
    .c dchars test 7 9
    .c index test insert
} {5}
    
test canvText-10.1 {TextToPoint procedure} {
    .c coords test 0 0
    .c itemconfig test -text 0 -anchor center
    .c index test @0,0
} {0}

test canvText-11.1 {TextToArea procedure} {
    .c coords test 0 0
    .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
    .c itemconfig test -text 0 -anchor center
    .c find overlapping 1000 1000 1001 1001
} {}

test canvText-12.1 {ScaleText procedure} {
    .c coords test 100 100
    .c scale all 50 50 2 2
    .c coords test
} {150.0 150.0}

test canvText-13.1 {TranslateText procedure} {
    .c coords test 100 100
    .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} {
    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} {
    .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 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 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 itemconfig -text "abcdefg"
    .c icursor test 3
    .c index test insert
} {3}

test canvText-16.1 {GetSelText procedure} {
    .c itemconfig test -text "abcdefghijklmno" -anchor nw
    .c select from test 5
    .c select to test 8
    selection get
} {fghi}

set font {Courier 12 italic}
set ax [font measure $font 0]
set ay [font metrics $font -linespace]

test canvText-17.1 {TextToPostscript procedure} {
    .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
0.000 0.000 0.000 setrgbcolor AdjustColor
100 200 \[
(000)
(000)
(00)
] $ay -0.5 0 0 false DrawText
grestore
restore showpage

%%Trailer
end
%%EOF
"