summaryrefslogtreecommitdiffstats
path: root/tests/canvText.test
blob: 20a39b076fea1977c8d46f55fa75921b5fc9e7de (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
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.

package require tcltest 2.1
eval tcltest::configure $argv
tcltest::loadTestedCommands

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"}}
    {-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}

.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 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} {
    .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 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 nonPortable} {
    .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.0 {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-7.9 {DisplayText procedure: select end} {
    catch {destroy .t}
    toplevel .t
    wm geometry .t +0+0
    canvas .t.c
    pack .t.c
    set id [.t.c create text 0 0 -text Dummy -anchor nw]
    update
    .t.c select from $id 0
    .t.c select to $id end
    update
    #catch {destroy .t}
    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
    format {%.6g %.6g} {*}[.c coords test]
} {150 150}

test canvText-13.1 {TranslateText procedure} {
    .c coords test 100 100
    .c move all 10 10
    format {%.6g %.6g} {*}[.c coords test]
} {110 110}

.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-14.6 {select clear errors} -body {
    .c select clear test
} -returnCodes error -result "wrong \# args: should be \".c select clear\""

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 0 false DrawText
grestore
restore showpage

%%Trailer
end
%%EOF
"

test canvText-18.1 {bug fix 2525, find enclosed on text with newlines} -body {
    catch {destroy .c}
    canvas .c
    pack .c
    .c delete all
    .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]
} -cleanup {
    unset -nocomplain bbox x2 y2
} -result 1

test canvText-19.1 {patch 1006286, leading space caused wrap under Win32} {
    catch {destroy .c}
    set c [canvas .c -bg black -width 964]
    pack $c
    $c delete all
    after 1000 "set done 1" ; vwait done

    set f {Arial 28 bold}

    set s1 {    Yeah-ah-ah-ah-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-Yow}
    set s2 {    Yeah ah ah ah oh oh oh oh oh oh oh oh oh oh oh oh oh oh oh oh Yow}

    $c create text 21 18 \
        -font $f \
        -text $s1 \
        -fill white \
        -width 922 \
        -anchor nw \
        -tags tbox1
    eval {$c create rect} [$c bbox tbox1] -outline red

    $c create text 21 160 \
        -font $f \
        -text $s2 \
        -fill white \
        -width 922 \
        -anchor nw \
        -tags tbox2
    eval {$c create rect} [$c bbox tbox2] -outline red

    after 1000 "set done 1" ; vwait done

    set results [list]

    $c select from tbox2 4
    $c select to tbox2 8
    lappend results [selection get]

    $c select from tbox1 4
    $c select to tbox1 8
    lappend results [selection get]

    array set metrics [font metrics $f]
    set x [expr {21 + [font measure $f "    "] \
        + ([font measure {Arial 28 bold} "Y"] / 2)}]
    set y1 [expr {18 + ($metrics(-linespace) / 2)}]
    set y2 [expr {160 + ($metrics(-linespace) / 2)}]

    lappend results [$c index tbox1 @$x,$y1]
    lappend results [$c index tbox2 @$x,$y2]

    set results
} {{Yeah } Yeah- 4 4}


# cleanup
cleanupTests
return