# 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. # # RCS: @(#) $Id: canvText.test,v 1.12.2.1 2004/08/09 23:48:11 mdejong 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 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 {} {}} {-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 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 .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 " test canvText-18.1 {bug fix 2525, find enclosed on text with newlines} { 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] } 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 ::tcltest::cleanupTests return