Subversion Repositories or1k

# 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.

#

# RCS: @(#) $Id: canvText.test,v 1.1.1.1 2002-01-16 10:25:58 markom Exp $

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

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

"