Import Tk 8.5.15 (as of svn r89086)
This commit is contained in:
Zachary Ware
575
tests/canvText.test
Normal file
575
tests/canvText.test
Normal file
@@ -0,0 +1,575 @@
|
||||
# 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} {
|
||||
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
|
||||
cleanupTests
|
||||
return
|
||||
Reference in New Issue
Block a user