# 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-2000 Ajuba Solutions.
# All rights reserved.

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

source [file join [file dirname [info script]] errorMessages.tcl]

set i 1
foreach {testname testinfo} [list \
    canvas-1.1  [list -background #ff0000 #ff0000 non-existent {unknown color name "non-existent"}] \
    canvas-1.2  [list -bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}] \
    canvas-1.3  [list -bd 4 4 badValue [errMsgBadDistance "badValue"]] \
    canvas-1.4  [list -borderwidth 1.3 1.3 badValue [errMsgBadDistance "badValue"]] \
    canvas-1.5  [list -closeenough 24 24.0 bogus {expected floating-point number but got "bogus"}] \
    canvas-1.6  [list -confine true 1 silly {expected boolean value but got "silly"}] \
    canvas-1.7  [list -cursor arrow arrow badValue {bad cursor spec "badValue"}] \
    canvas-1.8  [list -height 2.1 2 x42 [errMsgBadDistance "x42"]] \
    canvas-1.9  [list -highlightbackground #112233 #112233 ugly {unknown color name "ugly"}] \
    canvas-1.10 [list -highlightcolor #110022 #110022 bogus {unknown color name "bogus"}] \
    canvas-1.11 [list -highlightthickness 18 18 badValue [errMsgBadDistance "badValue"]] \
    canvas-1.12 [list -insertbackground #110022 #110022 bogus {unknown color name "bogus"}] \
    canvas-1.13 [list -insertborderwidth 1.3 1 2.6x [errMsgBadDistance "2.6x"]] \
    canvas-1.14 [list -insertofftime 100 100 3.2 {expected integer but got "3.2"}] \
    canvas-1.15 [list -insertontime 100 100 3.2 {expected integer but got "3.2"}] \
    canvas-1.16 [list -insertwidth 1.3 1 6x [errMsgBadDistance "6x"]] \
    canvas-1.17 [list -relief groove groove 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}] \
    canvas-1.18 [list -selectbackground #110022 #110022 bogus {unknown color name "bogus"}] \
    canvas-1.19 [list -selectborderwidth 1.3 1 badValue [errMsgBadDistance "badValue"]] \
    canvas-1.20 [list -selectforeground #654321 #654321 bogus {unknown color name "bogus"}] \
    canvas-1.21 [list -takefocus "any string" "any string" {} {}] \
    canvas-1.22 [list -width 402 402 xyz [errMsgBadDistance "xyz"]] \
    canvas-1.23 [list -xscrollcommand {Some command} {Some command} {} {}] \
    canvas-1.24 [list -yscrollcommand {Another command} {Another command} {} {}] \
] {
    lassign $testinfo name goodValue goodResult badValue badResult
    test $testname-good "configuration options: good value for $name" \
-setup ::tkp_setup \
-result $goodResult \
-body {
	.c configure $name $goodValue
	lindex [.c configure $name] 4
}
    incr i
    if {$badValue ne ""} {
	test $testname-bad "configuration options: bad value for $name" \
-setup ::tkp_setup \
-returnCodes error \
-result $badResult \
-body {
    .c configure $name $badValue
}
    }
    .c configure $name [lindex [.c configure $name] 3]
    incr i
}

test canvas-1.25 {configure throws error on bad option} \
-setup ::tkp_setup \
-result [list 1 1] \
-body {
    set res [list [catch {.c configure -gorp foo}]]
    .c create rect 10 10 100 100
    lappend res [catch {.c configure -gorp foo}]
    set res
}

test canvas-2.1 {CanvasWidgetCmd, bind option} \
-setup ::tkp_setup \
-result {0 {}} \
-body {
    set i [.c create rect 10 10 100 100]
    list [catch {.c bind $i <a>} msg] $msg
}

test canvas-2.2 {CanvasWidgetCmd, bind option} \
-setup ::tkp_setup \
-result {1 {no event type or button # or keysym}} \
-body {
    set i [.c create rect 10 10 100 100]
    list [catch {.c bind $i <} msg] $msg
}

test canvas-2.3 {CanvasWidgetCmd, xview option} \
-setup ::tkp_setup \
-result {{0.0 0.3} {0.4 0.7}} \
-body {
    .c configure -width 60 -height 40 -scrollregion {0 0 200 150} -bd 0 \
	-highlightthickness 0
    .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]
}

test canvas-2.4 {CanvasWidgetCmd, xview option} \
-setup ::tkp_setup \
-result {{0.6 0.9} {0.66 0.96}} \
-body {
    .c configure -width 60 -height 40 -scrollregion {0 0 200 150} -bd 0 \
	-highlightthickness 0
    # 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]
}

test canvas-3.1 {CanvasWidgetCmd, yview option} \
-setup ::tkp_setup \
-result {{0.0 0.5} {0.1875 0.6875}} \
-body {
    .c configure -width 60 -height 40 -scrollregion {0 0 200 80} \
	-borderwidth 0 -highlightthickness 0
    .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]
}

test canvas-3.2 {CanvasWidgetCmd, yview option} \
-setup ::tkp_setup \
-result {{0.0 0.5} {0.1 0.6}} \
-body {
    .c configure -width 60 -height 40 -scrollregion {0 0 200 80} \
	-borderwidth 0 -highlightthickness 0
    .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]
}

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

test canvas-5.1 {ButtonCmdDeletedProc procedure} \
-setup ::tkp_setup \
-result {{} {}} \
-body {
    rename .c {}
    list [info command .c*] [winfo children .]
}

test canvas-6.1 {CanvasSetOrigin procedure} \
-setup ::tkp_setup \
-result {-205.0 -105.0} \
-body {
    .c configure -width 100 -height 50 -scrollregion {-200 -100 305 102} \
	-borderwidth 2 -highlightthickness 3
    .c configure -xscrollincrement 0 -yscrollincrement 0 \
	-width 100 -height 50 -scrollregion {-200 -100 305 102} \
	-borderwidth 2 -highlightthickness 3
    update
    .c xview moveto 0
    .c yview moveto 0
    update
    list [.c canvasx 0] [.c canvasy 0]
}

test canvas-6.2 {CanvasSetOrigin procedure} \
-setup ::tkp_setup \
-result {-165.0 -145.0 35.0 55.0} \
-body {
    .c configure -width 100 -height 50 -scrollregion {-200 -100 305 102} \
	-borderwidth 2 -highlightthickness 3
    .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
}

test canvas-6.3 {CanvasSetOrigin procedure} \
-setup ::tkp_setup \
-result {-95.0 -85.0 35.0 45.0} \
-body {
    .c configure -width 100 -height 50 -scrollregion {-200 -100 305 102} \
	-borderwidth 2 -highlightthickness 3
    .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
}

test canvas-6.4 {CanvasSetOrigin procedure} \
-setup ::tkp_setup \
-result {215.0} \
-body {
    .c configure -width 100 -height 50 -scrollregion {-200 -100 305 102} \
	-borderwidth 2 -highlightthickness 3
    .c configure -xscrollincrement 20 -yscrollincrement 10
    update
    .c xview moveto 1.0
    .c canvasx 0
}

test canvas-6.5 {CanvasSetOrigin procedure} \
-setup ::tkp_setup \
-result {55.0} \
-body {
    .c configure -width 100 -height 50 -scrollregion {-200 -100 305 102} \
	-borderwidth 2 -highlightthickness 3
    .c configure -xscrollincrement 20 -yscrollincrement 10
    update
    .c yview moveto 1.0
    .c canvasy 0
}

test canvas-7.1 {canvas widget vs hidden commands} \
-setup ::tkp_setup \
-result [list {} 0] \
-body {
    set l [lsort [interp hidden]]
    interp hide {} .c
    destroy .c
    list [winfo children .] [string compare [lsort [interp hidden]] $l]
}

test canvas-8.1 {canvas arc bbox} \
-setup ::tkp_setup \
-result {{48 21 100 94} {248 21 300 94} {398 21 500 112}} \
-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]
    list $arcBox $coordBox $pieBox
}

test canvas-9.1 {canvas id creation and deletion} \
-setup ::tkp_setup \
-result {} \
-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 ""
}

test canvas-10.1 {find items using tag expressions} \
-setup ::tkp_setup \
-result {{0 3 4 6 7} {1 3} {1 2 3 4 6} 5 {0 5 7} 1 {3 4 5 6} {3 4 5 6} {3 4 5 6} 2 7 7} \
-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"]
    set res {}
    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"]
}

test canvas-10.2 {check errors from tag expressions} \
-setup ::tkp_setup \
-returnCodes error \
-result {Unexpected operator in tag search expression} \
-body {
    .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"]
    .c find withtag {&&c}
}

test canvas-10.3 {check errors from tag expressions} \
-setup ::tkp_setup \
-returnCodes error \
-result {Too many '!' in tag search expression} \
-body {
    .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"]
    .c find withtag {!!c}
}

test canvas-10.4 {check errors from tag expressions} \
-setup ::tkp_setup \
-returnCodes error \
-result {Missing tag in tag search expression} \
-body {
    .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"]
    .c find withtag {b||}
}

test canvas-10.5 {check errors from tag expressions} \
-setup ::tkp_setup \
-returnCodes error \
-result {Unexpected operator in tag search expression} \
-body {
    .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"]
    .c find withtag {b&&(c||)}
}

test canvas-10.6 {check errors from tag expressions} \
-setup ::tkp_setup \
-returnCodes error \
-result {Null quoted tag string in tag search expression} \
-body {
    .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"]
    .c find withtag {d&&""}
}

test canvas-10.7 {check errors from tag expressions} \
-setup ::tkp_setup \
-returnCodes error \
-result {Missing endquote in tag search expression} \
-body {
    .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"]
    .c find withtag "d&&\"tag with spaces"
}

test canvas-10.8 {check errors from tag expressions} \
-setup ::tkp_setup \
-returnCodes error \
-result {Invalid boolean operator in tag search expression} \
-body {
    .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"]
    .c find withtag {a&&"tag with spaces"z}
}

test canvas-10.9 {check errors from tag expressions} \
-setup ::tkp_setup \
-returnCodes error \
-result {Singleton '&' in tag search expression} \
-body {
    .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"]
    .c find withtag {a&&b&c}
}

test canvas-10.10 {check errors from tag expressions} \
-setup ::tkp_setup \
-returnCodes error \
-result {Singleton '|' in tag search expression} \
-body {
    .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"]
    .c find withtag {a||b|c}
}

test canvas-10.11 {backward compatility, strange tags that are not expressions} \
-setup ::tkp_setup \
-result 1 \
-body {
    .c create oval 20 20 40 40 -fill red -tag [list { strange tag(xxx&yyy|zzz) " && \" || ! ^ " }]
    .c find withtag { strange tag(xxx&yyy|zzz) " && \" || ! ^ " }
}

test canvas-10.12 {multple events bound to same tag expr} \
-setup ::tkp_setup \
-result {} \
-body {
    .c bind {a && b} <Enter> {puts Enter}
    .c bind {a && b} <Leave> {puts Leave}
}

test canvas-11.1 {canvas poly fill check, bug 5783} \
-setup ::tkp_setup \
-result 1 \
-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
}

test canvas-11.2 {canvas poly overlap fill check, bug 226357} \
-setup ::tkp_setup \
-result {1 1 {} 1 {} 1 1 {} 1 {} 1} \
-body {
    set result {}
    .c create polygon 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
}

test canvas-12.1 {canvas mm obj, patch SF-403327, 102471} \
-setup ::tkp_setup \
-result {2.0 3} \
-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]
}

test canvas-12.2 {canvas mm obj, patch SF-403327, 102471} \
-setup ::tkp_setup \
-result 12 \
-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
}

test canvas-13.1 {canvas delete during event, SF bug-228024} \
-setup ::tkp_setup \
-result okokokokokokokokokokokokokokokokokokokokokokokokokokokokokok \
-body {
proc ::tkp_kill_canvas {w} {
    destroy $w
    pack [tkp::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
    }
    ]
}
    ::tkp_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 <1> -x 100 -y 100
	event generate .c <ButtonRelease-1> -x 100 -y 100
    }
rename ::tkp_kill_canvas {}
    set ::x
}

test canvas-14.1 {canvas scan SF bug 581560} \
-setup ::tkp_setup \
-returnCodes error \
-result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"} \
-body {
    .c scan
}

test canvas-14.2 {canvas scan} \
-setup ::tkp_setup \
-returnCodes error \
-result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"} \
-body {
    .c scan bogus
}

test canvas-14.3 {canvas scan} \
-setup ::tkp_setup \
-returnCodes error \
-result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"} \
-body {
    .c scan mark
}

test canvas-14.4 {canvas scan} \
-setup ::tkp_setup \
-result {} \
-body {
    .c scan mark 10 10
}

test canvas-14.5 {canvas scan} \
-setup ::tkp_setup \
-returnCodes error \
-result {wrong # args: should be ".c scan mark x y"} \
-body {
    .c scan mark 10 10 5
}

test canvas-14.6 {canvas scan} \
-setup ::tkp_setup \
-result {} \
-body {
    .c scan dragto 10 10 5
}

set i 0
foreach type {arc bitmap image line oval polygon rect text window} {
    incr i
    test canvas-15.$i "basic types check: $type requires coords" \
-setup ::tkp_setup \
-returnCodes error \
-result [format {wrong # args: should be ".c create %s coords ?arg arg ...?"} $type] \
-body {
    .c create $type
}
    incr i
    test canvas-15.$i "basic coords check: $type coords are paired" \
-setup ::tkp_setup \
-match glob \
-returnCodes error \
-result "wrong # coordinates: expected*" \
-body {
    .c create $type 0
}
}

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

test canvas-17.1 {default smooth method handling} \
-setup ::tkp_setup \
-result {0 true true true raw raw true} \
-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]
    }
    set result
}

# cleanup
::tkp_cleanup
return
