# 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 © 1995-1996 Sun Microsystems, Inc.
# Copyright © 1998-2000 Ajuba Solutions.
# Copyright © 2008 Donal K. Fellows
# All rights reserved.

package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
imageInit

# XXX - This test file is woefully incomplete. At present, only a few of the
# features are tested.

# Canvas used in 1.* test cases
canvas .c
pack .c
update

test canvas-1.1 {configuration options: good value for "background"} -body {
    .c configure -background #ff0000
    .c cget -background
} -result {#ff0000}
test canvas-1.2 {configuration options: bad value for "background"} -body {
    .c configure -background non-existent
} -returnCodes error -result {unknown color name "non-existent"}
test canvas-1.3 {configuration options: good value for "bg"} -body {
    .c configure -bg #ff0000
    .c cget -bg
} -result {#ff0000}
test canvas-1.4 {configuration options: bad value for "bg"} -body {
    .c configure -bg non-existent
} -returnCodes error -result {unknown color name "non-existent"}
test canvas-1.5 {configuration options: good value for "bd"} -body {
    .c configure -bd 4
    .c cget -bd
} -result 4
test canvas-1.6 {configuration options: bad value for "bd"} -body {
    .c configure -bd badValue
} -returnCodes error -result {bad screen distance "badValue"}
test canvas-1.7 {configuration options: good value for "borderwidth"} -body {
    .c configure -borderwidth 1.3
    .c cget -borderwidth
} -result 1
test canvas-1.8 {configuration options: bad value for "borderwidth"} -body {
    .c configure -borderwidth badValue
} -returnCodes error -result {bad screen distance "badValue"}
test canvas-1.9 {configuration options: good value for "closeenough"} -body {
    .c configure -closeenough 24
    .c cget -closeenough
} -result {24.0}
test canvas-1.10 {configuration options: bad value for "closeenough"} -body {
    .c configure -closeenough bogus
} -returnCodes error -result {expected floating-point number but got "bogus"}
test canvas-1.11 {configuration options: good value for "confine"} -body {
    .c configure -confine true
    .c cget -confine
} -result 1
test canvas-1.12 {configuration options: bad value for "confine"} -body {
    .c configure -confine silly
} -returnCodes error -result {expected boolean value but got "silly"}
test canvas-1.13 {configuration options: good value for "cursor"} -body {
    .c configure -cursor arrow
    .c cget -cursor
} -result {arrow}
test canvas-1.14 {configuration options: bad value for "cursor"} -body {
    .c configure -cursor badValue
} -returnCodes error -result {bad cursor spec "badValue"}
test canvas-1.15 {configuration options: good value for "height"} -body {
    .c configure -height 2.1
    .c cget -height
} -result 2
test canvas-1.16 {configuration options: bad value for "height"} -body {
    .c configure -height x42
} -returnCodes error -result {bad screen distance "x42"}
test canvas-1.17 {configuration options: good value for "highlightbackground"} -body {
    .c configure -highlightbackground #112233
    .c cget -highlightbackground
} -result {#112233}
test canvas-1.18 {configuration options: bad value for "highlightbackground"} -body {
    .c configure -highlightbackground ugly
} -returnCodes error -result {unknown color name "ugly"}
test canvas-1.19 {configuration options: good value for "highlightcolor"} -body {
    .c configure -highlightcolor #110022
    .c cget -highlightcolor
} -result {#110022}
test canvas-1.20 {configuration options: bad value for "highlightcolor"} -body {
    .c configure -highlightcolor bogus
} -returnCodes error -result {unknown color name "bogus"}
test canvas-1.21 {configuration options: good value for "highlightthickness"} -body {
    .c configure -highlightthickness 18
    .c cget -highlightthickness
} -result 18
test canvas-1.22 {configuration options: bad value for "highlightthickness"} -body {
    .c configure -highlightthickness badValue
} -returnCodes error -result {bad screen distance "badValue"}
test canvas-1.23 {configuration options: good value for "insertbackground"} -body {
    .c configure -insertbackground #110022
    .c cget -insertbackground
} -result {#110022}
test canvas-1.24 {configuration options: bad value for "insertbackground"} -body {
    .c configure -insertbackground bogus
} -returnCodes error -result {unknown color name "bogus"}
test canvas-1.25 {configuration options: good value for "insertborderwidth"} -body {
    .c configure -insertborderwidth 1.3
    .c cget -insertborderwidth
} -result 1
test canvas-1.26 {configuration options: bad value for "insertborderwidth"} -body {
    .c configure -insertborderwidth 2.6x
} -returnCodes error -result {bad screen distance "2.6x"}
test canvas-1.27 {configuration options: good value for "insertofftime"} -body {
    .c configure -insertofftime 100
    .c cget -insertofftime
} -result 100
test canvas-1.28 {configuration options: bad value for "insertofftime"} -body {
    .c configure -insertofftime 3.2
} -returnCodes error -result {expected integer but got "3.2"}
test canvas-1.29 {configuration options: good value for "insertontime"} -body {
    .c configure -insertontime 100
    .c cget -insertontime
} -result 100
test canvas-1.30 {configuration options: bad value for "insertontime"} -body {
    .c configure -insertontime 3.2
} -returnCodes error -result {expected integer but got "3.2"}
test canvas-1.31 {configuration options: good value for "insertwidth"} -body {
    .c configure -insertwidth 1.3
    .c cget -insertwidth
} -result 1
test canvas-1.32 {configuration options: bad value for "insertwidth"} -body {
    .c configure -insertwidth 6x
} -returnCodes error -result {bad screen distance "6x"}
test canvas-1.33 {configuration options: good value for "relief"} -body {
    .c configure -relief groove
    .c cget -relief
} -result {groove}
test canvas-1.34 {configuration options: bad value for "relief"} -body {
    .c configure -relief 1.5
} -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}
test canvas-1.35 {configuration options: good value for "selectbackground"} -body {
    .c configure -selectbackground #110022
    .c cget -selectbackground
} -result {#110022}
test canvas-1.36 {configuration options: bad value for "selectbackground"} -body {
    .c configure -selectbackground bogus
} -returnCodes error -result {unknown color name "bogus"}
test canvas-1.37 {configuration options: good value for "selectborderwidth"} -body {
    .c configure -selectborderwidth 1.3
    .c cget -selectborderwidth
} -result 1
test canvas-1.38 {configuration options: bad value for "selectborderwidth"} -body {
    .c configure -selectborderwidth badValue
} -returnCodes error -result {bad screen distance "badValue"}
test canvas-1.39 {configuration options: good value for "selectforeground"} -body {
    .c configure -selectforeground #654321
    .c cget -selectforeground
} -result {#654321}
test canvas-1.40 {configuration options: bad value for "selectforeground"} -body {
    .c configure -selectforeground bogus
} -returnCodes error -result {unknown color name "bogus"}
test canvas-1.41 {configuration options: good value for "takefocus"} -body {
    .c configure -takefocus "any string"
    .c cget -takefocus
} -result {any string}
test canvas-1.42 {configuration options: good value for "width"} -body {
    .c configure -width 402
    .c cget -width
} -result 402
test canvas-1.43 {configuration options: bad value for "width"} -body {
    .c configure -width xyz
} -returnCodes error -result {bad screen distance "xyz"}
test canvas-1.44 {configuration options: good value for "xscrollcommand"} -body {
    .c configure -xscrollcommand {Some command}
    .c cget -xscrollcommand
} -result {Some command}
test canvas-1.45 {configuration options: good value for "yscrollcommand"} -body {
    .c configure -yscrollcommand {Another command}
    .c cget -yscrollcommand
} -result {Another command}
test canvas-1.46 {configure throws error on bad option} -body {
    .c configure -gorp foo
} -returnCodes error -match glob -result {*}
test canvas-1.47 {configure throws error on bad option} -body {
    catch {.c configure -gorp foo}
    .c create rect 10 10 100 100
    .c configure -gorp foo
} -returnCodes error -match glob -result {*}
catch {destroy .c}

# Canvas used in 2.* test cases
canvas .c -width 60 -height 40 -scrollregion {0 0 200 150} -bd 0 \
	-highlightthickness 0
pack .c
update

test canvas-2.1 {CanvasWidgetCmd, bind option} -body {
    set i [.c create rect 10 10 100 100]
    .c bind $i <a>
} -cleanup {
    .c delete $i
} -returnCodes ok
test canvas-2.2 {CanvasWidgetCmd, bind option} -body {
    set i [.c create rect 10 10 100 100]
    .c bind $i <
} -cleanup {
    .c delete $i
} -returnCodes error -result {no event type or button # or keysym}
test canvas-2.3 {CanvasWidgetCmd, xview option} -body {
    .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]
} -result {{0.0 0.3} {0.4 0.7}}
test canvas-2.4 {CanvasWidgetCmd, xview option} -body {
    .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]
} -result {{0.6 0.9} {0.66 0.96}}
test canvas-2.5 {CanvasWidgetCmd, raise/lower option, no error on non-existing tags} -setup {
    .c create line 0 0 10 10 -tags aline
} -body {
    .c raise aline noline
    .c raise bline aline
    .c lower aline noline
    .c lower bline aline
} -cleanup {
    .c delete aline
} -result {}
catch {destroy .c}

# Canvas used in 3.* test cases
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} -body {
    .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]
} -result {{0.0 0.5} {0.1875 0.6875}}
test canvas-3.2 {CanvasWidgetCmd, yview option} -body {
    .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]
} -result {{0.0 0.5} {0.1 0.6}}
destroy .c

test canvas-4.1 {ButtonEventProc procedure} -setup {
    deleteWindows
    set x {}
} -body {
    canvas .c1 -bg #543210
    rename .c1 .c2
    lappend x [winfo children .]
    lappend x [.c2 cget -bg]
    destroy .c1
    lappend x [info command .c*] [winfo children .]
} -result {.c1 #543210 {} {}}

test canvas-5.1 {ButtonCmdDeletedProc procedure} -body {
    canvas .c1
    rename .c1 {}
    list [info command .c*] [winfo children .]
} -cleanup {
    destroy .c1
} -result {{} {}}

# Canvas used in 6.* test cases
canvas .c -width 100 -height 50 -scrollregion {-200 -100 305 102} \
	-borderwidth 2 -highlightthickness 3
pack .c
update

test canvas-6.1 {CanvasSetOrigin procedure} -body {
    .c configure -xscrollincrement 0 -yscrollincrement 0
    .c xview moveto 0
    .c yview moveto 0
    update
    list [.c canvasx 0] [.c canvasy 0]
} -result {-205.0 -105.0}
test canvas-6.2 {CanvasSetOrigin procedure} -body {
    .c configure -xscrollincrement 20 -yscrollincrement 10
    set x ""
    foreach i {.08 .10 .48 .50} {
	.c xview moveto $i
	update
	lappend x [.c canvasx 0]
    }
    return $x
} -result {-165.0 -145.0 35.0 55.0}
test canvas-6.3 {CanvasSetOrigin procedure} -body {
    .c configure -xscrollincrement 20 -yscrollincrement 10
    set x ""
    foreach i {.06 .08 .70 .72} {
	.c yview moveto $i
	update
	lappend x [.c canvasy 0]
    }
    return $x
} -result {-95.0 -85.0 35.0 45.0}
test canvas-6.4 {CanvasSetOrigin procedure} -body {
    .c configure -xscrollincrement 20 -yscrollincrement 10
    .c xview moveto 1.0
    .c canvasx 0
} -result {215.0}
test canvas-6.5 {CanvasSetOrigin procedure} -body {
    .c configure -xscrollincrement 20 -yscrollincrement 10
    .c yview moveto 1.0
    .c canvasy 0
} -result {55.0}
deleteWindows

test canvas-7.1 {canvas widget vs hidden commands} -setup {
    canvas .c
} -body {
    interp hide {} .c
    destroy .c
    list [winfo children .] [lsort [interp hidden]]
} -cleanup {
    destroy .c
} -result [list {} [lsort [interp hidden]]]

test canvas-8.1 {canvas arc bbox} -setup {
    catch {destroy .c}
    canvas .c
} -body {
    .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]
    .c create arc 100 200 300 200 -height [expr {(1-0.5*sqrt(3))*200}] -style arc -tags arc4
    set arcSegBox [.c bbox arc4]
    list $arcBox $coordBox $pieBox $arcSegBox
} -result {{48 21 100 94} {248 21 300 94} {398 21 500 112} {98 171 302 202}}
test canvas-8.2 {canvas very small arc} -setup {
    catch {destroy .c}
    canvas .c
} -body {
    # no Inf or NaN must be generated even for very small arcs
    .c create arc 0 100 0 100 -height 100 -style arc -outline "" -tags arc1
    set arcBox [.c bbox arc1]
    .c create arc 0 100 0 100 -height 100 -style arc -outline blue -tags arc2
    set outlinedArcBox [.c bbox arc2]
    set coords [.c coords arc1]
    set start [.c itemcget arc1 -start]
    set extent [.c itemcget arc1 -extent]
    set width [.c itemcget arc1 -width]
    set height [.c itemcget arc1 -height]
    list $arcBox $outlinedArcBox $coords $start $extent $width $height
} -result {{-1 99 1 101} {-2 98 2 102} {0.0 100.0 0.0 100.0} 0.0 0.0 1.0 0.0}

test canvas-9.1 {canvas id creation and deletion} -setup {
    catch {destroy .c}
    canvas .c
} -body {
    # 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
    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 ""
} -result {}

test canvas-10.1 {find items using tag expressions} -setup {
    catch {destroy .c}
    canvas .c
    set res {}
} -body {
    .c create oval 20 20 40 40 -fill red -tag [list a b c d]
    .c create oval 20 60 40 80 -fill yellow -tag [list b a]
    .c create oval 20 100 40 120 -fill green -tag [list c b]
    .c create oval 20 140 40 160 -fill blue -tag [list b]
    .c create oval 20 180 40 200 -fill bisque -tag [list a d e]
    .c create oval 20 220 40 240 -fill bisque -tag b
    .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
    lappend res [.c find withtag {!a}]
    lappend res [.c find withtag {b&&c}]
    lappend res [.c find withtag {b||c}]
    lappend res [.c find withtag {a&&!b}]
    lappend res [.c find withtag {!b&&!c}]
    lappend res [.c find withtag {d&&a&&c&&b}]
    lappend res [.c find withtag {b^a}]
    lappend res [.c find withtag {(a&&!b)||(!a&&b)}]
    lappend res [.c find withtag { ( a && ! b ) || ( ! a && b ) }]
    lappend res [.c find withtag {a&&!(c||d)}]
    lappend res [.c find withtag {d&&"tag with spaces"}]
    lappend res [.c find withtag "tag with spaces"]
} -result {{3 4 6 7} {1 3} {1 2 3 4 6} 5 {5 7} 1 {3 4 5 6} {3 4 5 6} {3 4 5 6} 2 7 7}
test canvas-10.2 {check errors from tag expressions} -setup {
    catch {destroy .c}
    canvas .c
    .c create oval 20 20 40 40 -fill red -tag [list a b c d]
    .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
} -body {
    .c find withtag {&&c}
} -returnCodes error -result {unexpected operator in tag search expression}
test canvas-10.3 {check errors from tag expressions} -setup {
    catch {destroy .c}
    canvas .c
    .c create oval 20 20 40 40 -fill red -tag [list a b c d]
    .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
} -body {
    .c find withtag {!!c}
} -returnCodes error -result {too many '!' in tag search expression}
test canvas-10.4 {check errors from tag expressions} -setup {
    catch {destroy .c}
    canvas .c
    .c create oval 20 20 40 40 -fill red -tag [list a b c d]
    .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
} -body {
    .c find withtag {b||}
} -returnCodes error -result {missing tag in tag search expression}
test canvas-10.5 {check errors from tag expressions} -setup {
    catch {destroy .c}
    canvas .c
    .c create oval 20 20 40 40 -fill red -tag [list a b c d]
    .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
} -body {
    .c find withtag {b&&(c||)}
} -returnCodes error -result {unexpected operator in tag search expression}
test canvas-10.6 {check errors from tag expressions} -setup {
    catch {destroy .c}
    canvas .c
    .c create oval 20 20 40 40 -fill red -tag [list a b c d]
    .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
} -body {
    .c find withtag {d&&""}
} -returnCodes error -result {null quoted tag string in tag search expression}
test canvas-10.7 {check errors from tag expressions} -setup {
    catch {destroy .c}
    canvas .c
    .c create oval 20 20 40 40 -fill red -tag [list a b c d]
    .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
} -body {
    .c find withtag "d&&\"tag with spaces"
} -returnCodes error -result {missing endquote in tag search expression}
test canvas-10.8 {check errors from tag expressions} -setup {
    catch {destroy .c}
    canvas .c
    .c create oval 20 20 40 40 -fill red -tag [list a b c d]
    .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
} -returnCodes error -body {
    .c find withtag {a&&"tag with spaces"z}
} -result {invalid boolean operator in tag search expression}
test canvas-10.9 {check errors from tag expressions} -setup {
    catch {destroy .c}
    canvas .c
    .c create oval 20 20 40 40 -fill red -tag [list a b c d]
    .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
} -body {
    .c find withtag {a&&b&c}
} -returnCodes error -result {singleton '&' in tag search expression}
test canvas-10.10 {check errors from tag expressions} -setup {
    catch {destroy .c}
    canvas .c
    .c create oval 20 20 40 40 -fill red -tag [list a b c d]
    .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"]
} -body {
    .c find withtag {a||b|c}
} -returnCodes error -result {singleton '|' in tag search expression}
test canvas-10.11 {backward compatility - strange tags that are not expressions} -setup {
    catch {destroy .c}
    canvas .c
    .c create oval 20 20 40 40 -fill red \
	-tag [list { strange tag(xxx&yyy|zzz) " && \" || ! ^ " }]
} -body {
    .c find withtag { strange tag(xxx&yyy|zzz) " && \" || ! ^ " }
} -result 1
test canvas-10.12 {multple events bound to same tag expr} -setup {
    catch {destroy .c}
    canvas .c
} -body {
    .c bind {a && b} <Enter> {puts Enter}
    .c bind {a && b} <Leave> {puts Leave}
} -result {}
test canvas-10.13 {more long tag searches; Bug 2931374} -setup {
    catch {destroy .c}
    canvas .c
} -body {
    .c find withtag {(A&&B&&C&&D)&&area&&!text}
    # memory errors on failure
} -cleanup {
    destroy .c
} -result {}

test canvas-11.1 {canvas poly fill check, bug 5783} -setup {
    destroy .c
    pack [canvas .c]
} -body {
    # This would crash in 8.3.0 and 8.3.1
    .c create polygon 0 0 100 100 200 50 \
	    -fill {} -stipple gray50 -outline black
} -result 1
test canvas-11.2 {canvas poly overlap fill check, bug 226357} -setup {
    destroy .c
    pack [canvas .c]
    set result {}
} -body {
    .c create poly 30 30 90 90 30 90 90 30
    lappend result [.c find over 40 40 45 45];	# rect region inc. edge
    lappend result [.c find over 60 40 60 40];	# top-center point
    lappend result [.c find over 0 0 0 0];	# not on poly
    lappend result [.c find over 60 60 60 60];	# center-point
    lappend result [.c find over 45 50 45 50];	# outside poly
    .c itemconfig 1 -fill "" -outline black
    lappend result [.c find over 40 40 45 45];	# rect region inc. edge
    lappend result [.c find over 60 40 60 40];	# top-center point
    lappend result [.c find over 0 0 0 0];	# not on poly
    lappend result [.c find over 60 60 60 60];	# center-point
    lappend result [.c find over 45 50 45 50];	# outside poly
    .c itemconfig 1 -width 8
    lappend result [.c find over 45 50 45 50];	# outside poly
} -result {1 1 {} 1 {} 1 1 {} 1 {} 1}
test canvas-11.3 {canvas poly dchars, bug 3291543} {
    # This would crash
    destroy .c
    pack [canvas .c]
    .c create polygon 0 0 0 10 10 0
    .c dchars 1 2 end
    .c coords 1
} {}

test canvas-12.1 {canvas mm obj, patch SF-403327, 102471} -setup {
    destroy .c
    pack [canvas .c]
} -body {
    set qx [expr {1.+1.}]
    # qx has type double and no string representation
    .c scale all $qx 0 1. 1.
    # qx has now type MMRep and no string representation
    list $qx [string length $qx]
} -result {2.0 3}
test canvas-12.2 {canvas mm obj, patch SF-403327, 102471} -setup {
    destroy .c
    pack [canvas .c]
} -body {
    set val 10
    incr val
    # qx has type double and no string representation
    .c scale all $val 0 1 1
    # qx has now type MMRep and no string representation
    incr val
} -result 12

# procedure used in 13.1 test case
proc kill_canvas {w} {
    destroy $w
    pack [canvas $w -height 200 -width 200] -fill both -expand yes
    update idle
    $w create rectangle 80 80 120 120 -fill blue -tags blue
    # bind a button press to re-build the canvas
    $w bind blue <ButtonRelease-1> [subst {
	[lindex [info level 0] 0] $w
	append ::x ok
    }]
}
test canvas-13.1 {canvas delete during event, SF bug-228024} -body {
    kill_canvas .c
    set ::x {}
    # do this many times to improve chances of triggering the crash
    for {set i 0} {$i < 30} {incr i} {
	event generate .c <Button-1> -x 100 -y 100
	event generate .c <ButtonRelease-1> -x 100 -y 100
    }
    return $::x
} -result {okokokokokokokokokokokokokokokokokokokokokokokokokokokokokok}

test canvas-14.1 {canvas scan SF bug 581560} -setup {
    destroy .c
    canvas .c
} -returnCodes error -body {
    .c scan
} -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"}
test canvas-14.2 {canvas scan} -setup {
    destroy .c
    canvas .c
} -returnCodes error -body {
    .c scan bogus
} -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"}
test canvas-14.3 {canvas scan} -setup {
    destroy .c
    canvas .c
} -returnCodes error -body {
    .c scan mark
} -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"}
test canvas-14.4 {canvas scan} -setup {
    destroy .c
    canvas .c
} -body {
    .c scan mark 10 10
} -result {}
test canvas-14.5 {canvas scan} -setup {
    destroy .c
    canvas .c
} -body {
    .c scan mark 10 10 5
} -returnCodes error -result {wrong # args: should be ".c scan mark x y"}
test canvas-14.6 {canvas scan} -setup {
    destroy .c
    canvas .c
} -body {
    .c scan dragto 10 10 5
} -result {}

test canvas-15.1 {basic types check: arc requires coords} -setup {
    destroy .c
    canvas .c
} -returnCodes error -body {
    .c create arc
} -result {wrong # args: should be ".c create arc coords ?arg ...?"}
test canvas-15.2 "basic coords check: arc coords are paired" -setup {
    destroy .c
    canvas .c
} -body {
    .c create arc 0
} -returnCodes error -result {wrong # coordinates: expected 4, got 1}
test canvas-15.3 {basic types check: bitmap requires coords} -setup {
    destroy .c
    canvas .c
} -returnCodes error -body {
    .c create bitmap
} -result {wrong # args: should be ".c create bitmap coords ?arg ...?"}
test canvas-15.4 "basic coords check: bitmap coords are paired" -setup {
    destroy .c
    canvas .c
} -body {
    .c create bitmap 0
} -returnCodes error -result {wrong # coordinates: expected 2, got 1}
test canvas-15.5 {basic types check: image requires coords} -setup {
    destroy .c
    canvas .c
} -returnCodes error -body {
    .c create image
} -result {wrong # args: should be ".c create image coords ?arg ...?"}
test canvas-15.6 "basic coords check: image coords are paired" -setup {
    destroy .c
    canvas .c
} -returnCodes error -body {
    .c create image 0
} -result {wrong # coordinates: expected 2, got 1}
test canvas-15.7 {basic types check: line requires coords} -setup {
    destroy .c
    canvas .c
} -returnCodes error -body {
    .c create line
} -result {wrong # args: should be ".c create line coords ?arg ...?"}
test canvas-15.8 "basic coords check: line coords are paired" -setup {
    destroy .c
    canvas .c
} -returnCodes error -body {
    .c create line 0
} -result {wrong # coordinates: expected an even number, got 1}
test canvas-15.9 {basic types check: oval requires coords} -setup {
    destroy .c
    canvas .c
} -returnCodes error -body {
    .c create oval
} -result {wrong # args: should be ".c create oval coords ?arg ...?"}
test canvas-15.10 "basic coords check: oval coords are paired" -setup {
    destroy .c
    canvas .c
} -returnCodes error -body {
    .c create oval 0
} -result {wrong # coordinates: expected 0 or 4, got 1}
test canvas-15.11 {basic types check: polygon requires coords} -setup {
    destroy .c
    canvas .c
} -returnCodes error -body {
    .c create polygon
} -result {wrong # args: should be ".c create polygon coords ?arg ...?"}
test canvas-15.12 "basic coords check: polygon coords are paired" -setup {
    destroy .c
    canvas .c
} -returnCodes error -body {
    .c create polygon 0
} -result {wrong # coordinates: expected an even number, got 1}
test canvas-15.13 {basic types check: rect requires coords} -setup {
    destroy .c
    canvas .c
} -returnCodes error -body {
    .c create rect
} -result {wrong # args: should be ".c create rect coords ?arg ...?"}
test canvas-15.14 "basic coords check: rect coords are paired" -setup {
    destroy .c
    canvas .c
} -returnCodes error -body {
    .c create rect 0
} -result {wrong # coordinates: expected 0 or 4, got 1}
test canvas-15.15 {basic types check: text requires coords} -setup {
    destroy .c
    canvas .c
} -returnCodes error -body {
    .c create text
} -result {wrong # args: should be ".c create text coords ?arg ...?"}
test canvas-15.16 "basic coords check: text coords are paired" -setup {
    destroy .c
    canvas .c
} -returnCodes error -body {
    .c create text 0
} -result {wrong # coordinates: expected 2, got 1}
test canvas-15.17 {basic types check: window requires coords} -setup {
    destroy .c
    canvas .c
} -returnCodes error -body {
    .c create window
} -result {wrong # args: should be ".c create window coords ?arg ...?"}
test canvas-15.18 "basic coords check: window coords are paired" -setup {
    destroy .c
    canvas .c
} -returnCodes error -body {
    .c create window 0
} -result {wrong # coordinates: expected 2, got 1}
test canvas-15.19 "basic coords check: centimeters are larger than pixels" -setup {
    destroy .c
    canvas .c
} -body {
    set id [.c create rect 0 0 1cm 1cm]
    expr {[lindex [.c coords $id] 2]>1}
} -result 1
test canvas-15.20 {bug [237971ce]} -setup {
    destroy .c
    canvas .c
} -body {
    set id [.c create line {0 0 50 50 100 50}]
    .c insert $id end {200 200}
    .c coords $id
} -result {0.0 0.0 50.0 50.0 100.0 50.0 200.0 200.0}
test canvas-15.21 {bug [237971ce]} -setup {
    destroy .c
    canvas .c
} -body {
    set id [.c create poly {0 0 50 50 100 50}]
    .c insert $id end {200 200}
    .c coords $id
} -result {0.0 0.0 50.0 50.0 100.0 50.0 200.0 200.0}
destroy .c

test canvas-16.1 {arc coords check} -setup {
    canvas .c
} -body {
    set id [.c create arc {0 10 20 30} -start 33]
    .c itemcget $id -start
} -cleanup {
    destroy .c
} -result {33.0}

test canvas-17.1 {default smooth method handling} -setup {
    canvas .c
} -body {
    set id [.c create line {0 0 1 1 2 2 3 3 4 4 5 5 6 6}]
    set result [.c itemcget $id -smooth]
    foreach smoother {yes 1 bezier raw r b} {
	.c itemconfigure $id -smooth $smoother
	lappend result [.c itemcget $id -smooth]
    }
    return $result
} -cleanup {
    destroy .c
} -result {0 true true true raw raw true}

test canvas-18.1 {imove method - lines} -setup {
    canvas .c
} -body {
    set id [.c create line 0 0 1 1 2 2 3 3]
    .c imove $id 0 4 4
    .c coords $id
} -cleanup {
    destroy .c
} -result {4.0 4.0 1.0 1.0 2.0 2.0 3.0 3.0}
test canvas-18.2 {imove method - lines} -setup {
    canvas .c
} -body {
    set id [.c create line 0 0 1 1]
    .c imove $id 0 4 4
    .c coords $id
} -cleanup {
    destroy .c
} -result {4.0 4.0 1.0 1.0}
test canvas-18.3 {imove method - lines} -setup {
    canvas .c
} -body {
    set id [.c create line 0 0 1 1 2 2 3 3]
    .c imove $id @1,1 4 4
    .c coords $id
} -cleanup {
    destroy .c
} -result {0.0 0.0 4.0 4.0 2.0 2.0 3.0 3.0}
test canvas-18.4 {imove method - lines} -constraints knownBug -setup {
    canvas .c
} -body {
    set id [.c create line 0 0 1 1 2 2 3 3]
    .c imove $id end 4 4
    .c coords $id
} -cleanup {
    destroy .c
} -result {0.0 0.0 1.0 1.0 2.0 2.0 4.0 4.0}
test canvas-18.5 {imove method - polygon} -setup {
    canvas .c
} -body {
    set id [.c create polygon 0 0 1 1 2 2 3 3]
    .c imove $id 0 4 4
    .c coords $id
} -cleanup {
    destroy .c
} -result {4.0 4.0 1.0 1.0 2.0 2.0 3.0 3.0}
test canvas-18.6 {imove method - polygon} -setup {
    canvas .c
} -body {
    set id [.c create polygon 0 0 1 1]
    .c imove $id 0 4 4
    .c coords $id
} -cleanup {
    destroy .c
} -result {4.0 4.0 1.0 1.0}
test canvas-18.7 {imove method - polygon} -setup {
    canvas .c
} -body {
    set id [.c create polygon 0 0 1 1 2 2 3 3]
    .c imove $id @1,1 4 4
    .c coords $id
} -cleanup {
    destroy .c
} -result {0.0 0.0 4.0 4.0 2.0 2.0 3.0 3.0}
test canvas-18.8 {imove method - polygon} -constraints knownBug -setup {
    canvas .c
} -body {
    set id [.c create polygon 0 0 1 1 2 2 3 3]
    .c imove $id end 4 4
    .c coords $id
} -cleanup {
    destroy .c
} -result {0.0 0.0 1.0 1.0 2.0 2.0 4.0 4.0}
test canvas-18.9 {imove method - errors} -setup {
    canvas .c
} -body {
    set id [.c create line 0 0 1 1 2 2 3 3]
    .c imove $id foobar 4 4
} -cleanup {
    destroy .c
} -returnCodes error -result {bad index "foobar"}
test canvas-18.10 {imove method - errors} -setup {
    canvas .c
} -body {
    set id [.c create line 0 0 1 1 2 2 3 3]
    .c imove $id 0 foobar 4
} -cleanup {
    destroy .c
} -returnCodes error -result {bad screen distance "foobar"}
test canvas-18.11 {imove method - errors} -setup {
    canvas .c
} -body {
    set id [.c create line 0 0 1 1 2 2 3 3]
    .c imove $id 0 4 foobar
} -cleanup {
    destroy .c
} -returnCodes error -result {bad screen distance "foobar"}

test canvas-19.1 {rchars method - lines} -setup {
    canvas .c
} -body {
    set id [.c create line 0 0 1 1 2 2 3 3]
    .c rchars $id 2 4 {4 4}
    .c coords $id
} -cleanup {
    destroy .c
} -result {0.0 0.0 4.0 4.0 3.0 3.0}
test canvas-19.2 {rchars method - lines} -setup {
    canvas .c
} -body {
    set id [.c create line 0 0 1 1 2 2 3 3]
    .c rchars $id 2 4 {}
    .c coords $id
} -cleanup {
    destroy .c
} -result {0.0 0.0 3.0 3.0}
test canvas-19.3 {rchars method - lines} -setup {
    canvas .c
} -body {
    set id [.c create line 0 0 1 1 2 2 3 3]
    .c rchars $id 2 4 {10 11 12 13 14 15}
    .c coords $id
} -cleanup {
    destroy .c
} -result {0.0 0.0 10.0 11.0 12.0 13.0 14.0 15.0 3.0 3.0}
test canvas-19.4 {rchars method - polygon} -setup {
    canvas .c
} -body {
    set id [.c create polygon 0 0 1 1 2 2 3 3]
    .c rchars $id 2 4 {4 4}
    .c coords $id
} -cleanup {
    destroy .c
} -result {0.0 0.0 4.0 4.0 3.0 3.0}
test canvas-19.5 {rchars method - polygon} -setup {
    canvas .c
} -body {
    set id [.c create polygon 0 0 1 1 2 2 3 3]
    .c rchars $id 2 4 {}
    .c coords $id
} -cleanup {
    destroy .c
} -result {0.0 0.0 3.0 3.0}
test canvas-19.6 {rchars method - polygon} -setup {
    canvas .c
} -body {
    set id [.c create polygon 0 0 1 1 2 2 3 3]
    .c rchars $id 2 4 {10 11 12 13 14 15}
    .c coords $id
} -cleanup {
    destroy .c
} -result {0.0 0.0 10.0 11.0 12.0 13.0 14.0 15.0 3.0 3.0}
test canvas-19.7 {rchars method - text} -setup {
    canvas .c
} -body {
    set id [.c create text 0 0 -text abcde]
    .c rchars $id 1 3 XYZ
    .c itemcget $id -text
} -cleanup {
    destroy .c
} -result aXYZe
test canvas-19.8 {rchars method - text} -setup {
    canvas .c
} -body {
    set id [.c create text 0 0 -text abcde]
    .c rchars $id 1 3 {}
    .c itemcget $id -text
} -cleanup {
    destroy .c
} -result ae
test canvas-19.9 {rchars method - text} -setup {
    canvas .c
} -body {
    set id [.c create text 0 0 -text abcde]
    .c rchars $id 1 3 FOOBAR
    .c itemcget $id -text
} -cleanup {
    destroy .c
} -result aFOOBARe
test canvas-19.10 {rchars method - errors} -setup {
    canvas .c
} -body {
    set id [.c create line 0 0 1 1]
    .c rchars $id foo 1 {2 2}
} -cleanup {
    destroy .c
} -returnCodes error -result {bad index "foo"}
test canvas-19.11 {rchars method - errors} -setup {
    canvas .c
} -body {
    set id [.c create line 0 0 1 1]
    .c rchars $id 1 foo {2 2}
} -cleanup {
    destroy .c
} -returnCodes error -result {bad index "foo"}

test canvas-20.1 {addtag/dtag - no shuffling of tag sequence} -setup {
    canvas .c
    .c create text 100 100 -text Hello
} -body {
    for {set i 1} {$i < 5} {incr i} {
        .c addtag tag$i all
    }
    # [.c addtags] only adds tags that are not already present
    .c addtag tag1 all   ; # no effect
    set res [list [.c gettags 1]]
    .c dtag 1 tag2
    lappend res [.c gettags 1]
} -cleanup {
    destroy .c
} -result {{tag1 tag2 tag3 tag4} {tag1 tag3 tag4}}
test canvas-20.2 {tag deletion - multiple tags with same name, no shuffling} -setup {
    canvas .c
    .c create text 100 100 -text Hello
} -body {
    # [.c itemconfigure -tags] lets the user add duplicate tags
    # this is not a problem although inconsistent with [.c addtags]
    .c itemconfigure 1 -tags {tagA tagB tagA tagA tagC tagA}
    set res [list [.c gettags 1]]
    .c dtag 1 tagA
    lappend res [.c gettags 1]
} -cleanup {
    destroy .c
} -result {{tagA tagB tagA tagA tagC tagA} {tagB tagC}}
test canvas-20.3 {tag deletion - all tags match} -setup {
    canvas .c
    .c create text 100 100 -text Hello
} -body {
    # [.c itemconfigure -tags] lets the user add duplicate tags
    # this is not a problem although inconsistent with [.c addtags]
    .c itemconfigure 1 -tags {tagA tagA tagA tagA tagA tagA}
    set res [list [.c gettags 1]]
    .c dtag 1 tagA
    lappend res [.c gettags 1]
} -cleanup {
    destroy .c
} -result {{tagA tagA tagA tagA tagA tagA} {}}

destroy .c
test canvas-21.1 {canvas rotate} -setup {
    pack [canvas .c]
} -body {
    .c create line 50 50 50 100 100 100
    .c rotate all 75 75 90
    lmap c [.c coords all] {format %.2f $c}
} -cleanup {
    destroy .c
} -result {50.00 100.00 100.00 100.00 100.00 50.00}
test canvas-21.2 {canvas rotate} -setup {
    pack [canvas .c]
} -body {
    .c create line 50 50 50 100 100 100
    .c rotate all 75 75 -10
    lmap c [.c coords all] {format %.2f $c}
} -cleanup {
    destroy .c
} -result {54.72 46.04 46.04 95.28 95.28 103.96}
test canvas-21.3 {canvas rotate: syntax} -setup {
    pack [canvas .c]
} -body {
    .c rotate all 75 75
} -returnCodes error -cleanup {
    destroy .c
} -result {wrong # args: should be ".c rotate tagOrId x y angle"}
test canvas-21.4 {canvas rotate: syntax} -setup {
    pack [canvas .c]
} -body {
    .c rotate all 75 75 123 123
} -returnCodes error -cleanup {
    destroy .c
} -result {wrong # args: should be ".c rotate tagOrId x y angle"}
test canvas-21.5 {canvas rotate: syntax} -setup {
    pack [canvas .c]
} -body {
    .c rotate {!} 1 1 1
} -returnCodes error -cleanup {
    destroy .c
} -result {missing tag in tag search expression}
test canvas-21.6 {canvas rotate: syntax} -setup {
    pack [canvas .c]
} -body {
    .c rotate all x 1 1
} -returnCodes error -cleanup {
    destroy .c
} -result {bad screen distance "x"}
test canvas-21.7 {canvas rotate: syntax} -setup {
    pack [canvas .c]
} -body {
    .c rotate all 1 x 1
} -returnCodes error -cleanup {
    destroy .c
} -result {bad screen distance "x"}
test canvas-21.8 {canvas rotate: syntax} -setup {
    pack [canvas .c]
} -body {
    .c rotate all 1 1 x
} -returnCodes error -cleanup {
    destroy .c
} -result {expected floating-point number but got "x"}
test canvas-21.9 {canvas rotate: nothing to rotate} -setup {
    pack [canvas .c]
} -body {
    .c rotate all 75 75 10
} -cleanup {
    destroy .c
} -result {}
test canvas-21.10 {canvas rotate: multiple things to rotate} -setup {
    pack [canvas .c]
} -body {
    .c create line 50 50 50 100 -tag a
    .c create line 50 50 100 50 -tag b
    .c rotate all 75 75 45
    list [lmap c [.c coords a] {format %.2f $c}] [lmap c [.c coords b] {format %.2f $c}]
} -cleanup {
    destroy .c
} -result {{39.64 75.00 75.00 110.36} {39.64 75.00 75.00 39.64}}

test canvas-22.1 {canvas rotate: arc item rotation behaviour} -setup {
    pack [canvas .c]
} -body {
    .c create arc 50 50 75 75 -start 45 -extent 90
    .c rotate all 100 100 90
    list [lmap c [.c coords all] {format %.2f $c}] \
	[lmap o {-start -extent} {.c itemcget all $o}] \
	[.c bbox all]
} -cleanup {
    destroy .c
} -result {{50.00 125.00 75.00 150.00} {45.0 90.0} {52 123 73 140}}
test canvas-22.2 {canvas rotate: bitmap item rotation behaviour} -setup {
    pack [canvas .c]
} -body {
    .c create bitmap 50 50 -bitmap info -anchor se
    .c rotate all 100 100 90
    list [lmap c [.c coords all] {format %.2f $c}] \
	[lmap o {-bitmap -anchor} {.c itemcget all $o}] \
	[.c bbox all]
} -cleanup {
    destroy .c
} -result {{50.00 150.00} {info se} {42 129 50 150}}
test canvas-22.3 {canvas rotate: image item rotation behaviour} -setup {
    pack [canvas .c]
    image create photo dummy -width 50 -height 50
} -body {
    .c create image 50 50 -image dummy -anchor se
    .c rotate all 100 100 90
    list [lmap c [.c coords all] {format %.2f $c}] \
	[lmap o {-image -anchor} {.c itemcget all $o}] \
	[.c bbox all]
} -cleanup {
    destroy .c
    image delete dummy
} -result {{50.00 150.00} {dummy se} {0 100 50 150}}
test canvas-22.4 {canvas rotate: line item rotation behaviour} -setup {
    pack [canvas .c]
} -body {
    .c create line 50 50 75 50 50 75 75 75
    .c rotate all 100 100 90
    list [lmap c [.c coords all] {format %.2f $c}] \
	[lmap o {} {.c itemcget all $o}] \
	[.c bbox all]
} -cleanup {
    destroy .c
} -result {{50.00 150.00 50.00 125.00 75.00 150.00 75.00 125.00} {} {48 123 77 152}}
test canvas-22.5 {canvas rotate: oval item rotation behaviour} -setup {
    pack [canvas .c]
} -body {
    .c create oval 50 50 65 85
    .c rotate all 100 100 90
    list [lmap c [.c coords all] {format %.2f $c}] \
	[lmap o {} {.c itemcget all $o}] \
	[.c bbox all]
} -cleanup {
    destroy .c
} -result {{60.00 125.00 75.00 160.00} {} {59 124 76 161}}
test canvas-22.6 {canvas rotate: polygon item rotation behaviour} -setup {
    pack [canvas .c]
} -body {
    .c create polygon 50 50 75 50 50 75 75 75
    .c rotate all 100 100 90
    list [lmap c [.c coords all] {format %.2f $c}] \
	[lmap o {} {.c itemcget all $o}] \
	[.c bbox all]
} -cleanup {
    destroy .c
} -result {{50.00 150.00 50.00 125.00 75.00 150.00 75.00 125.00} {} {48 123 77 152}}
test canvas-22.7 {canvas rotate: rectangle item rotation behaviour} -setup {
    pack [canvas .c]
} -body {
    .c create rectangle 50 50 75 75
    .c rotate all 100 100 90
    list [lmap c [.c coords all] {format %.2f $c}] \
	[lmap o {} {.c itemcget all $o}] \
	[.c bbox all]
} -cleanup {
    destroy .c
} -result {{50.00 125.00 75.00 150.00} {} {49 124 76 151}}
test canvas-22.8 {canvas rotate: text item rotation behaviour} -setup {
    pack [canvas .c]
} -body {
    .c create text 50 50 -text foo -angle 45
    .c rotate all 100 100 90
    list [lmap c [.c coords all] {format %.2f $c}] \
	[lmap o {-text -angle} {.c itemcget all $o}]
    # [.c bbox all]
    # No testing of text bounding box; fonts too variable!
} -cleanup {
    destroy .c
} -result {{50.00 150.00} {foo 45.0}}
test canvas-22.9 {canvas rotate: window item rotation behaviour} -setup {
    pack [canvas .c]
} -body {
    .c create window 50 50 -window [frame .c.f -width 25 -height 25] \
	-anchor se
    .c rotate all 100 100 90
    list [lmap c [.c coords all] {format %.2f $c}] \
	[lmap o {} {.c itemcget all $o}] \
	[.c bbox all]
} -cleanup {
    destroy .c
} -result {{50.00 150.00} {} {25 125 50 150}}

# Procedure used in test cases 23.1 23.2 23.3
proc matchPixels {pixels expected} {
    set matched 1
    foreach pline $pixels eline $expected {
        foreach ppixel $pline epixel $eline {
            if {$ppixel != $epixel} {
                set matched 0
                break
            }
        }
    }
    return $matched
}

test canvas-23.1 {canvas image} -setup {
    canvas .c
    image create photo testimage
} -body  {
    .c configure -background #c0c0c0 -scrollregion {0 0 9 9}
    .c create rectangle 0 0 0 9 -fill #000080 -outline #000080
    .c image testimage
    matchPixels [testimage data] { \
            {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
            {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
            {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
            {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
            {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
            {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
            {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
            {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
            {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
            {#000080 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0}}
} -cleanup {
    destroy .c
    image delete testimage
} -result 1

test canvas-23.2 {canvas image with subsample} -setup {
    canvas .c
    image create photo testimage
} -body  {
    .c configure -background #c0c0c0 -scrollregion {0 0 9 9}
    .c create rectangle 0 0 1 9 -fill #008000 -outline #008000
    .c image testimage 2
    matchPixels [testimage data] { \
        {#008000 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
        {#008000 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
        {#008000 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
        {#008000 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
        {#008000 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0}}
} -cleanup {
    destroy .c
    image delete testimage
} -result 1

test canvas-23.3 {canvas image with subsample and zoom} -setup {
    canvas .c
    image create photo testimage
} -body  {
    .c configure -background #c0c0c0 -scrollregion {0 0 9 9}
    .c create rectangle 0 0 9 0 -fill #800000 -outline #800000
    .c image testimage 1 2
    matchPixels [testimage data] { \
        {#800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000} \
        {#800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000 #800000} \
        {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
        {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
        {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
        {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
        {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
        {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
        {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
        {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
        {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
        {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
        {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
        {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
        {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
        {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
        {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
        {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
        {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
        {#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0}}
} -cleanup {
    destroy .c
    image delete testimage
} -result 1

# cleanup
imageCleanup
cleanupTests
return

# Local Variables:
# mode: tcl
# End: