URL
https://opencores.org/ocsvn/or1k/or1k/trunk
Subversion Repositories or1k
[/] [or1k/] [trunk/] [insight/] [tk/] [tests/] [canvas.test] - Rev 1775
Go to most recent revision | Compare with Previous | Blame | View Log
# 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 <Return> $id {}
$c delete $id
}
}] 0]
set x ""
} {}
Go to most recent revision | Compare with Previous | Blame | View Log