Subversion Repositories or1k

# This file is a Tcl script to test out the procedures in tkCanvas.c,

# which implements generic code for canvases.  It is organized in the

# standard fashion for Tcl tests.

#

# Copyright (c) 1995-1996 Sun Microsystems, Inc.

# Copyright (c) 1998 by Scriptics Corporation.

#

# See the file "license.terms" for information on usage and redistribution

# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

#

# RCS: @(#) $Id: canvas.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 .

# XXX - This test file is woefully incomplete.  At present, only a

# few of the features are tested.

canvas .c

pack .c

update

set i 1

foreach test {

    {-background #ff0000 #ff0000 non-existent

            {unknown color name "non-existent"}}

    {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}}

    {-bd 4 4 badValue {bad screen distance "badValue"}}

    {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}

    {-closeenough 24 24.0 bogus {expected floating-point number but got "bogus"}}

    {-confine true 1 silly {expected boolean value but got "silly"}}

    {-cursor arrow arrow badValue {bad cursor spec "badValue"}}

    {-height 2.1 2 x42 {bad screen distance "x42"}}

    {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}}

    {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"}}

    {-highlightthickness 18 18 badValue {bad screen distance "badValue"}}

    {-insertbackground #110022 #110022 bogus {unknown color name "bogus"}}

    {-insertborderwidth 1.3 1 2.6x {bad screen distance "2.6x"}}

    {-insertofftime 100 100 3.2 {expected integer but got "3.2"}}

    {-insertontime 100 100 3.2 {expected integer but got "3.2"}}

    {-insertwidth 1.3 1 6x {bad screen distance "6x"}}

    {-relief groove groove 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}}

    {-selectbackground #110022 #110022 bogus {unknown color name "bogus"}}

    {-selectborderwidth 1.3 1 badValue {bad screen distance "badValue"}}

    {-selectforeground #654321 #654321 bogus {unknown color name "bogus"}}

    {-takefocus "any string" "any string" {} {}}

    {-width 402 402 xyz {bad screen distance "xyz"}}

    {-xscrollcommand {Some command} {Some command} {} {}}

    {-yscrollcommand {Another command} {Another command} {} {}}

} {

    set name [lindex $test 0]

    test canvas-1.$i {configuration options} {

        .c configure $name [lindex $test 1]

        lindex [.c configure $name] 4

    } [lindex $test 2]

    incr i

    if {[lindex $test 3] != ""} {

        test canvas-1.$i {configuration options} {

            list [catch {.c configure $name [lindex $test 3]} msg] $msg

        } [list 1 [lindex $test 4]]

    }

    .c configure $name [lindex [.c configure $name] 3]

    incr i

}

catch {destroy .c}

canvas .c -width 60 -height 40 -scrollregion {0 0 200 150} -bd 0 \

        -highlightthickness 0

pack .c

update

test canvas-2.1 {CanvasWidgetCmd, xview option} {

    .c configure -xscrollincrement 40 -yscrollincrement 5

    .c xview moveto 0

    update

    set x [list [.c xview]]

    .c xview scroll 2 units

    update

    lappend x [.c xview]

} {{0 0.3} {0.4 0.7}}

test canvas-2.2 {CanvasWidgetCmd, xview option} {nonPortable} {

    # This test gives slightly different results on platforms such

    # as NetBSD.  I don't know why...

    .c configure -xscrollincrement 0 -yscrollincrement 5

    .c xview moveto 0.6

    update

    set x [list [.c xview]]

    .c xview scroll 2 units

    update

    lappend x [.c xview]

} {{0.6 0.9} {0.66 0.96}}

catch {destroy .c}

canvas .c -width 60 -height 40 -scrollregion {0 0 200 80} \

        -borderwidth 0 -highlightthickness 0

pack .c

update

test canvas-3.1 {CanvasWidgetCmd, yview option} {

    .c configure -xscrollincrement 40 -yscrollincrement 5

    .c yview moveto 0

    update

    set x [list [.c yview]]

    .c yview scroll 3 units

    update

    lappend x [.c yview]

} {{0 0.5} {0.1875 0.6875}}

test canvas-3.2 {CanvasWidgetCmd, yview option} {

    .c configure -xscrollincrement 40 -yscrollincrement 0

    .c yview moveto 0

    update

    set x [list [.c yview]]

    .c yview scroll 2 units

    update

    lappend x [.c yview]

} {{0 0.5} {0.1 0.6}}

test canvas-4.1 {ButtonEventProc procedure} {

    eval destroy [winfo children .]

    canvas .c1 -bg #543210

    rename .c1 .c2

    set x {}

    lappend x [winfo children .]

    lappend x [.c2 cget -bg]

    destroy .c1

    lappend x [info command .c*] [winfo children .]

} {.c1 #543210 {} {}}

test canvas-5.1 {ButtonCmdDeletedProc procedure} {

    eval destroy [winfo children .]

    canvas .c1

    rename .c1 {}

    list [info command .c*] [winfo children .]

} {{} {}}

catch {destroy .c}

canvas .c -width 100 -height 50 -scrollregion {-200 -100 305 102} \

        -borderwidth 2 -highlightthickness 3

pack .c

update

test canvas-6.1 {CanvasSetOrigin procedure} {

    .c configure -xscrollincrement 0 -yscrollincrement 0

    .c xview moveto 0

    .c yview moveto 0

    update

    list [.c canvasx 0] [.c canvasy 0]

} {-205.0 -105.0}

test canvas-6.2 {CanvasSetOrigin procedure} {

    .c configure -xscrollincrement 20 -yscrollincrement 10

    set x ""

    foreach i {.08 .10 .48 .50} {

        .c xview moveto $i

        update

        lappend x [.c canvasx 0]

    }

    set x

} {-165.0 -145.0 35.0 55.0}

test canvas-6.3 {CanvasSetOrigin procedure} {

    .c configure -xscrollincrement 20 -yscrollincrement 10

    set x ""

    foreach i {.06 .08 .70 .72} {

        .c yview moveto $i

        update

        lappend x [.c canvasy 0]

    }

    set x

} {-95.0 -85.0 35.0 45.0}

test canvas-6.4 {CanvasSetOrigin procedure} {

    .c configure -xscrollincrement 20 -yscrollincrement 10

    .c xview moveto 1.0

    .c canvasx 0

} {215.0}

test canvas-6.5 {CanvasSetOrigin procedure} {

    .c configure -xscrollincrement 20 -yscrollincrement 10

    .c yview moveto 1.0

    .c canvasy 0

} {55.0}

set l [interp hidden]

eval destroy [winfo children .]

test canvas-7.1 {canvas widget vs hidden commands} {

    catch {destroy .c}

    canvas .c

    interp hide {} .c

    destroy .c

    list [winfo children .] [interp hidden]

} [list {} $l]

test canvas-8.1 {canvas arc bbox} {

    catch {destroy .c}

    canvas .c

    .c create arc -100 10 100 210 -start 10 -extent 50 -style arc -tags arc1

    set arcBox [.c bbox arc1]

    .c create arc 100 10 300 210 -start 10 -extent 50 -style chord -tags arc2

    set coordBox [.c bbox arc2]

    .c create arc 300 10 500 210 -start 10 -extent 50 -style pieslice -tags arc3

    set pieBox [.c bbox arc3]

    list $arcBox $coordBox $pieBox

} {{48 21 100 94} {248 21 300 94} {398 21 500 112}}

test canvas-9.1 {canvas id creation and deletion} {

    # With Tk 8.0.4 the ids are now stored in a hash table.  You

    # can use this test as a performance test with older versions

    # by changing the value of size.

    set size 15

    catch {destroy .c}

    set c [canvas .c]

    for {set i 0} {$i < $size} {incr i} {

        set x [expr {-10 + 3*$i}]

        for {set j 0; set y -10} {$j < 10} {incr j; incr y 3} {

            $c create rect ${x}c ${y}c [expr $x+2]c [expr $y+2]c \

                    -outline black -fill blue -tags rect

            $c create text [expr $x+1]c [expr $y+1]c -text "$i,$j" \

                    -anchor center -tags text

        }

    }

    # The actual bench mark - this code also exercises all the hash

    # table changes.

    set time [lindex [time {

        foreach id [$c find withtag all] {

            $c lower $id

            $c raise $id

            $c find withtag $id

            $c bind  $id {}

            $c delete $id

        }

    }] 0]

    set x ""

} {}