1# This file is a Tcl script to test out the procedures in tkCanvText.c, 2# which implement canvas "text" items. It is organized in the standard 3# fashion for Tcl tests. 4# 5# Copyright (c) 1996-1997 Sun Microsystems, Inc. 6# Copyright (c) 1998-1999 by Scriptics Corporation. 7# All rights reserved. 8# 9# RCS: @(#) $Id: canvText.test,v 1.12.2.1 2004/08/09 23:48:11 mdejong Exp $ 10 11package require tcltest 2.1 12namespace import -force tcltest::configure 13namespace import -force tcltest::testsDirectory 14configure -testdir [file join [pwd] [file dirname [info script]]] 15configure -loadfile [file join [testsDirectory] constraints.tcl] 16tcltest::loadTestedCommands 17 18canvas .c -width 400 -height 300 -bd 2 -relief sunken 19pack .c 20update 21 22set i 1 23.c create text 20 20 -tag test 24 25set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*" 26set ay [font metrics $font -linespace] 27set ax [font measure $font 0] 28 29 30foreach test { 31 {-anchor nw nw xyz {bad anchor position "xyz": must be n, ne, e, se, s, sw, w, nw, or center}} 32 {-fill #ff0000 #ff0000 xyz {unknown color name "xyz"}} 33 {-fill {} {} {} {}} 34 {-font {Times 40} {Times 40} {} {font "" doesn't exist}} 35 {-justify left left xyz {bad justification "xyz": must be left, right, or center}} 36 {-stipple gray50 gray50 xyz {bitmap "xyz" not defined}} 37 {-tags {test a b c} {test a b c} {} {}} 38 {-text xyz xyz {} {}} 39 {-width 6 6 xyz {bad screen distance "xyz"}} 40} { 41 set name [lindex $test 0] 42 test canvText-1.$i {configuration options} { 43 .c itemconfigure test $name [lindex $test 1] 44 list [lindex [.c itemconfigure test $name] 4] [.c itemcget test $name] 45 } [list [lindex $test 2] [lindex $test 2]] 46 incr i 47 if {[lindex $test 3] != ""} { 48 test canvText-1.$i {configuration options} { 49 list [catch {.c itemconfigure test $name [lindex $test 3]} msg] $msg 50 } [list 1 [lindex $test 4]] 51 } 52 incr i 53} 54test canvText-1.$i {configuration options} { 55 .c itemconfigure test -tags {test xyz} 56 .c itemcget xyz -tags 57} {test xyz} 58 59.c delete test 60.c create text 20 20 -tag test 61 62test canvText-2.1 {CreateText procedure: args} { 63 list [catch {.c create text} msg] $msg 64} {1 {wrong # args: should be ".c create text coords ?arg arg ...?"}} 65test canvText-2.2 {CreateText procedure: args} { 66 list [catch {.c create text xyz 0} msg] $msg 67} {1 {bad screen distance "xyz"}} 68test canvText-2.3 {CreateText procedure: args} { 69 list [catch {.c create text 0 xyz} msg] $msg 70} {1 {bad screen distance "xyz"}} 71test canvText-2.4 {CreateText procedure: args} { 72 list [catch {.c create text 0 0 -xyz xyz} msg] $msg 73} {1 {unknown option "-xyz"}} 74test canvText-2.5 {CreateText procedure} { 75 .c create text 0 0 -tags x 76 set x [.c coords x] 77 .c delete x 78 set x 79} {0.0 0.0} 80 81focus -force .c 82.c focus test 83.c coords test 0 0 84update 85 86test canvText-3.1 {TextCoords procedure} { 87 .c coords test 88} {0.0 0.0} 89test canvText-3.2 {TextCoords procedure} { 90 list [catch {.c coords test xyz 0} msg] $msg 91} {1 {bad screen distance "xyz"}} 92test canvText-3.3 {TextCoords procedure} { 93 list [catch {.c coords test 0 xyz} msg] $msg 94} {1 {bad screen distance "xyz"}} 95test canvText-3.4 {TextCoords procedure} { 96 .c coords test 10 10 97 set result {} 98 foreach element [.c coords test] { 99 lappend result [format %.1f $element] 100 } 101 set result 102} {10.0 10.0} 103test canvText-3.5 {TextCoords procedure} { 104 list [catch {.c coords test 10} msg] $msg 105} {1 {wrong # coordinates: expected 2, got 1}} 106test canvText-3.6 {TextCoords procedure} { 107 list [catch {.c coords test 10 10 10} msg] $msg 108} {1 {wrong # coordinates: expected 0 or 2, got 3}} 109 110test canvText-4.1 {ConfigureText procedure} { 111 list [catch {.c itemconfig test -fill xyz} msg] $msg 112} {1 {unknown color name "xyz"}} 113test canvText-4.2 {ConfigureText procedure} { 114 .c itemconfig test -fill blue 115 .c itemcget test -fill 116} {blue} 117test canvText-4.3 {ConfigureText procedure: construct font gcs} { 118 .c itemconfig test -font "times 20" -fill black -stipple gray50 119 list [.c itemcget test -font] [.c itemcget test -fill] [.c itemcget test -stipple] 120} {{times 20} black gray50} 121test canvText-4.4 {ConfigureText procedure: construct cursor gc} { 122 .c itemconfig test -text "abcdefg" 123 .c select from test 2 124 .c select to test 4 125 .c icursor test 3 126 127 # Both black -> cursor becomes white. 128 .c config -insertbackground black 129 .c config -selectbackground black 130 .c itemconfig test -just left 131 update 132 133 # Both same color (and not black) -> cursor becomes black. 134 .c config -insertbackground red 135 .c config -selectbackground red 136 .c itemconfig test -just left 137 update 138} {} 139test canvText-4.5 {ConfigureText procedure: adjust selection} { 140 set x {} 141 .c itemconfig test -text "abcdefghi" 142 .c select from test 2 143 .c select to test 6 144 lappend x [selection get] 145 .c dchars test 1 end 146 lappend x [catch {selection get}] 147 .c insert test end "bcdefghi" 148 .c select from test 2 149 .c select to test 6 150 lappend x [selection get] 151 .c dchars test 4 end 152 lappend x [selection get] 153 .c insert test end "efghi" 154 .c select from test 6 155 .c select to test 2 156 lappend x [selection get] 157 .c dchars test 4 end 158 lappend x [selection get] 159} {cdefg 1 cdefg cd cdef cd} 160test canvText-4.6 {ConfigureText procedure: adjust cursor} { 161 .c itemconfig test -text "abcdefghi" 162 set x {} 163 .c icursor test 6 164 .c dchars test 4 end 165 .c index test insert 166} {4} 167 168test canvText-5.1 {ConfigureText procedure: adjust cursor} { 169 .c create text 10 10 -tag x -fill blue -font "times 40" -stipple gray50 -text "xyz" 170 .c delete x 171} {} 172 173test canvText-6.1 {ComputeTextBbox procedure} {fonts nonPortable} { 174 .c itemconfig test -font $font -text 0 175 .c coords test 0 0 176 set x {} 177 lappend x [.c itemconfig test -anchor n; .c bbox test] 178 lappend x [.c itemconfig test -anchor nw; .c bbox test] 179 lappend x [.c itemconfig test -anchor w; .c bbox test] 180 lappend x [.c itemconfig test -anchor sw; .c bbox test] 181 lappend x [.c itemconfig test -anchor s; .c bbox test] 182 lappend x [.c itemconfig test -anchor se; .c bbox test] 183 lappend x [.c itemconfig test -anchor e; .c bbox test] 184 lappend x [.c itemconfig test -anchor ne; .c bbox test] 185 lappend x [.c itemconfig test -anchor center; .c bbox test] 186} "{[expr -$ax/2-1] 0 [expr $ax/2+1] $ay}\ 187{-1 0 [expr $ax+1] $ay}\ 188{-1 [expr -$ay/2] [expr $ax+1] [expr $ay/2]}\ 189{-1 -$ay [expr $ax+1] 0}\ 190{[expr -$ax/2-1] -$ay [expr $ax/2+1] 0}\ 191{[expr -$ax-1] -$ay 1 0}\ 192{[expr -$ax-1] [expr -$ay/2] 1 [expr $ay/2]}\ 193{[expr -$ax-1] 0 1 $ay}\ 194{[expr -$ax/2-1] [expr -$ay/2] [expr $ax/2+1] [expr $ay/2]}" 195 196focus .c 197.c focus test 198.c itemconfig test -text "abcd\nefghi\njklmnopq" 199test canvText-7.0 {DisplayText procedure: stippling} { 200 .c itemconfig test -stipple gray50 201 update 202 .c itemconfig test -stipple {} 203 update 204} {} 205test canvText-7.2 {DisplayText procedure: draw selection} { 206 .c select from test 0 207 .c select to test end 208 update 209 selection get 210} "abcd\nefghi\njklmnopq" 211test canvText-7.3 {DisplayText procedure: selection} { 212 .c select from test 0 213 .c select to test end 214 update 215 selection get 216} "abcd\nefghi\njklmnopq" 217test canvText-7.4 {DisplayText procedure: one line selection} { 218 .c select from test 2 219 .c select to test 3 220 update 221} {} 222test canvText-7.5 {DisplayText procedure: multi-line selection} { 223 .c select from test 2 224 .c select to test 12 225 update 226} {} 227test canvText-7.6 {DisplayText procedure: draw cursor} { 228 .c icursor test 3 229 update 230} {} 231test canvText-7.7 {DisplayText procedure: selected text different color} { 232 .c config -selectforeground blue 233 .c itemconfig test -anchor n 234 update 235} {} 236test canvText-7.8 {DisplayText procedure: not selected} { 237 .c select clear 238 update 239} {} 240test canvText-7.9 {DisplayText procedure: select end} { 241 catch {destroy .t} 242 toplevel .t 243 wm geometry .t +0+0 244 canvas .t.c 245 pack .t.c 246 set id [.t.c create text 0 0 -text Dummy -anchor nw] 247 update 248 .t.c select from $id 0 249 .t.c select to $id end 250 update 251 #catch {destroy .t} 252 update 253} {} 254 255test canvText-8.1 {TextInsert procedure: 0 length insert} { 256 .c insert test end {} 257} {} 258test canvText-8.2 {TextInsert procedure: before beginning/after end} { 259 # Can't test this because GetTextIndex filters out those numbers. 260} {} 261test canvText-8.3 {TextInsert procedure: inserting in a selected item} { 262 .c itemconfig test -text "abcdefg" 263 .c select from test 2 264 .c select to test 4 265 .c insert test 1 "xyz" 266 .c itemcget test -text 267} {axyzbcdefg} 268test canvText-8.4 {TextInsert procedure: inserting before selection} { 269 .c itemconfig test -text "abcdefg" 270 .c select from test 2 271 .c select to test 4 272 .c insert test 1 "xyz" 273 list [.c index test sel.first] [.c index test sel.last] 274} {5 7} 275test canvText-8.5 {TextInsert procedure: inserting in selection} { 276 .c itemconfig test -text "abcdefg" 277 .c select from test 2 278 .c select to test 4 279 .c insert test 3 "xyz" 280 list [.c index test sel.first] [.c index test sel.last] 281} {2 7} 282test canvText-8.6 {TextInsert procedure: inserting after selection} { 283 .c itemconfig test -text "abcdefg" 284 .c select from test 2 285 .c select to test 4 286 .c insert test 5 "xyz" 287 list [.c index test sel.first] [.c index test sel.last] 288} {2 4} 289test canvText-8.7 {TextInsert procedure: inserting in unselected item} { 290 .c itemconfig test -text "abcdefg" 291 .c select clear 292 .c insert test 5 "xyz" 293 .c itemcget test -text 294} {abcdexyzfg} 295test canvText-8.8 {TextInsert procedure: inserting before cursor} { 296 .c itemconfig test -text "abcdefg" 297 .c icursor test 3 298 .c insert test 2 "xyz" 299 .c index test insert 300} {6} 301test canvText-8.9 {TextInsert procedure: inserting after cursor} { 302 .c itemconfig test -text "abcdefg" 303 .c icursor test 3 304 .c insert test 4 "xyz" 305 .c index test insert 306} {3} 307 308test canvText-9.1 {TextInsert procedure: before beginning/after end} { 309 # Can't test this because GetTextIndex filters out those numbers. 310} {} 311test canvText-9.2 {TextInsert procedure: start > end} { 312 .c itemconfig test -text "abcdefg" 313 .c dchars test 4 2 314 .c itemcget test -text 315} {abcdefg} 316test canvText-9.3 {TextInsert procedure: deleting from a selected item} { 317 .c itemconfig test -text "abcdefg" 318 .c select from test 2 319 .c select to test 4 320 .c dchars test 3 5 321 .c itemcget test -text 322} {abcg} 323test canvText-9.4 {TextInsert procedure: deleting before start} { 324 .c itemconfig test -text "abcdefghijk" 325 .c select from test 4 326 .c select to test 8 327 .c dchars test 1 1 328 list [.c index test sel.first] [.c index test sel.last] 329} {3 7} 330test canvText-9.5 {TextInsert procedure: keep start > first char deleted} { 331 .c itemconfig test -text "abcdefghijk" 332 .c select from test 4 333 .c select to test 8 334 .c dchars test 2 6 335 list [.c index test sel.first] [.c index test sel.last] 336} {2 3} 337test canvText-9.6 {TextInsert procedure: deleting inside selection} { 338 .c itemconfig test -text "abcdefghijk" 339 .c select from test 4 340 .c select to test 8 341 .c dchars test 6 6 342 list [.c index test sel.first] [.c index test sel.last] 343} {4 7} 344test canvText-9.7 {TextInsert procedure: keep end > first char deleted} { 345 .c itemconfig test -text "abcdefghijk" 346 .c select from test 4 347 .c select to test 8 348 .c dchars test 6 10 349 list [.c index test sel.first] [.c index test sel.last] 350} {4 5} 351test canvText-9.8 {TextInsert procedure: selectFirst > selectLast: deselect} { 352 .c itemconfig test -text "abcdefghijk" 353 .c select from test 4 354 .c select to test 8 355 .c dchars test 3 10 356 list [catch {.c index test sel.first} msg] $msg 357} {1 {selection isn't in item}} 358test canvText-9.9 {TextInsert procedure: selectFirst <= selectLast} { 359 .c itemconfig test -text "abcdefghijk" 360 .c select from test 4 361 .c select to test 8 362 .c dchars test 4 7 363 list [.c index test sel.first] [.c index test sel.last] 364} {4 4} 365test canvText-9.10 {TextInsert procedure: move anchor} { 366 .c itemconfig test -text "abcdefghijk" 367 .c select from test 6 368 .c select to test 8 369 .c dchars test 2 4 370 .c select to test 1 371 list [.c index test sel.first] [.c index test sel.last] 372} {1 2} 373test canvText-9.11 {TextInsert procedure: keep anchor >= first} { 374 .c itemconfig test -text "abcdefghijk" 375 .c select from test 6 376 .c select to test 8 377 .c dchars test 5 7 378 .c select to test 1 379 list [.c index test sel.first] [.c index test sel.last] 380} {1 4} 381test canvText-9.12 {TextInsert procedure: anchor doesn't move} { 382 .c itemconfig test -text "abcdefghijk" 383 .c select from test 2 384 .c select to test 5 385 .c dchars test 6 8 386 .c select to test 8 387 list [.c index test sel.first] [.c index test sel.last] 388} {2 8} 389test canvText-9.13 {TextInsert procedure: move cursor} { 390 .c itemconfig test -text "abcdefghijk" 391 .c icursor test 6 392 .c dchars test 2 4 393 .c index test insert 394} {3} 395test canvText-9.14 {TextInsert procedure: keep cursor >= first} { 396 .c itemconfig test -text "abcdefghijk" 397 .c icursor test 6 398 .c dchars test 2 10 399 .c index test insert 400} {2} 401test canvText-9.15 {TextInsert procedure: cursor doesn't move} { 402 .c itemconfig test -text "abcdefghijk" 403 .c icursor test 5 404 .c dchars test 7 9 405 .c index test insert 406} {5} 407 408test canvText-10.1 {TextToPoint procedure} { 409 .c coords test 0 0 410 .c itemconfig test -text 0 -anchor center 411 .c index test @0,0 412} {0} 413 414test canvText-11.1 {TextToArea procedure} { 415 .c coords test 0 0 416 .c itemconfig test -text 0 -anchor center 417 .c find overlapping 0 0 1 1 418} [.c find withtag test] 419test canvText-11.2 {TextToArea procedure} { 420 .c coords test 0 0 421 .c itemconfig test -text 0 -anchor center 422 .c find overlapping 1000 1000 1001 1001 423} {} 424 425test canvText-12.1 {ScaleText procedure} { 426 .c coords test 100 100 427 .c scale all 50 50 2 2 428 .c coords test 429} {150.0 150.0} 430 431test canvText-13.1 {TranslateText procedure} { 432 .c coords test 100 100 433 .c move all 10 10 434 .c coords test 435} {110.0 110.0} 436 437.c itemconfig test -text "abcdefghijklmno" -anchor nw 438.c select from test 5 439.c select to test 8 440.c icursor test 12 441.c coords test 0 0 442test canvText-14.1 {GetTextIndex procedure} { 443 list [.c index test end] [.c index test insert] \ 444 [.c index test sel.first] [.c index test sel.last] \ 445 [.c index test @0,0] \ 446 [.c index test -1] [.c index test 10] [.c index test 100] 447} {15 12 5 8 0 0 10 15} 448test canvText-14.2 {GetTextIndex procedure: select error} { 449 .c select clear 450 list [catch {.c index test sel.first} msg] $msg 451} {1 {selection isn't in item}} 452test canvText-14.3 {GetTextIndex procedure: select error} { 453 .c select clear 454 list [catch {.c index test sel.last} msg] $msg 455} {1 {selection isn't in item}} 456test canvText-14.4 {GetTextIndex procedure: select error} { 457 .c select clear 458 list [catch {.c index test sel.} msg] $msg 459} {1 {bad index "sel."}} 460test canvText-14.5 {GetTextIndex procedure: bad int or unknown index} { 461 list [catch {.c index test xyz} msg] $msg 462} {1 {bad index "xyz"}} 463 464test canvText-15.1 {SetTextCursor procedure} { 465 .c itemconfig -text "abcdefg" 466 .c icursor test 3 467 .c index test insert 468} {3} 469 470test canvText-16.1 {GetSelText procedure} { 471 .c itemconfig test -text "abcdefghijklmno" -anchor nw 472 .c select from test 5 473 .c select to test 8 474 selection get 475} {fghi} 476 477set font {Courier 12 italic} 478set ax [font measure $font 0] 479set ay [font metrics $font -linespace] 480 481test canvText-17.1 {TextToPostscript procedure} { 482 .c delete all 483 .c config -height 300 -highlightthickness 0 -bd 0 484 update 485 .c create text 100 100 -tags test 486 .c itemconfig test -font $font -text "00000000" -width [expr 3*$ax] 487 .c itemconfig test -anchor n -fill black 488 set x [.c postscript] 489 set x [string range $x [string first "/Courier-Oblique" $x] end] 490} "/Courier-Oblique findfont [font actual $font -size] scalefont ISOEncode setfont 4910.000 0.000 0.000 setrgbcolor AdjustColor 492100 200 \[ 493\[(000)\] 494\[(000)\] 495\[(00)\] 496] $ay -0.5 0 0 false DrawText 497grestore 498restore showpage 499 500%%Trailer 501end 502%%EOF 503" 504 505test canvText-18.1 {bug fix 2525, find enclosed on text with newlines} { 506 catch {destroy .c} 507 canvas .c 508 pack .c 509 .c delete all 510 .c create text 100 100 -text Hello\n -anchor nw 511 set bbox [.c bbox 1] 512 set x2 [lindex $bbox 2] 513 set y2 [lindex $bbox 3] 514 incr y2 515 update 516 .c find enclosed 99 99 [expr $x2 + $i] [expr $y2 + 1] 517} 1 518 519test canvText-19.1 {patch 1006286, leading space caused wrap under Win32} { 520 catch {destroy .c} 521 set c [canvas .c -bg black -width 964] 522 pack $c 523 $c delete all 524 after 1000 "set done 1" ; vwait done 525 526 set f {Arial 28 bold} 527 528 set s1 { Yeah-ah-ah-ah-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-Yow} 529 set s2 { Yeah ah ah ah oh oh oh oh oh oh oh oh oh oh oh oh oh oh oh oh Yow} 530 531 $c create text 21 18 \ 532 -font $f \ 533 -text $s1 \ 534 -fill white \ 535 -width 922 \ 536 -anchor nw \ 537 -tags tbox1 538 eval {$c create rect} [$c bbox tbox1] -outline red 539 540 $c create text 21 160 \ 541 -font $f \ 542 -text $s2 \ 543 -fill white \ 544 -width 922 \ 545 -anchor nw \ 546 -tags tbox2 547 eval {$c create rect} [$c bbox tbox2] -outline red 548 549 after 1000 "set done 1" ; vwait done 550 551 set results [list] 552 553 $c select from tbox2 4 554 $c select to tbox2 8 555 lappend results [selection get] 556 557 $c select from tbox1 4 558 $c select to tbox1 8 559 lappend results [selection get] 560 561 array set metrics [font metrics $f] 562 set x [expr {21 + [font measure $f " "] \ 563 + ([font measure {Arial 28 bold} "Y"] / 2)}] 564 set y1 [expr {18 + ($metrics(-linespace) / 2)}] 565 set y2 [expr {160 + ($metrics(-linespace) / 2)}] 566 567 lappend results [$c index tbox1 @$x,$y1] 568 lappend results [$c index tbox2 @$x,$y2] 569 570 set results 571} {{Yeah } Yeah- 4 4} 572 573 574# cleanup 575::tcltest::cleanupTests 576return 577 578 579 580 581 582 583 584 585 586 587 588 589 590