# This file is a Tcl script to test out Tk's "tk_chooseColor" command.
#
# Copyright © 1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

package require tcltest 2.2; # needed in mode -singleproc 0

# Load the main script main.tcl, which takes care of:
# - setup for the application and the root window
# - importing commands from the tcltest namespace
# - loading of the testutils mechanism along with its utility procs
# - loading of Tk specific test constraints (additionally to constraints
#   provided by the package tcltest)
source [file join [tcltest::configure -testdir] main.tcl]

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import dialog

#
# LOCAL TEST CONSTRAINTS
#

if {[testConstraint defaultPseudocolor8]} {
    # let's soak up a bunch of colors...so that
    # machines with small color palettes still fail.
    # some tests will be skipped if there are no more colors
    set numcolors 32
    testConstraint colorsLeftover 1
    set i 0
    canvas .c
    pack .c -expand 1 -fill both
    while {$i<$numcolors} {
	set color \#[format "%02x%02x%02x" $i [expr $i+1] [expr $i+3]]
	.c create rectangle [expr 10+$i] [expr 10+$i] [expr 50+$i] [expr 50+$i] -fill $color -outline $color
	incr i
    }
    set i 0
    while {$i<$numcolors} {
	set color [.c itemcget $i -fill]
	if {$color != ""} {
	    foreach {r g b} [winfo rgb . $color] {}
	    set r [expr $r/256]
	    set g [expr $g/256]
	    set b [expr $b/256]
	    if {"$color" != "#[format %02x%02x%02x $r $g $b]"} {
		testConstraint colorsLeftover 0
	    }
	}
	.c delete $i
	incr i
    }
    destroy .c
} else {
    testConstraint colorsLeftover 1
}

#
# LOCAL UTILITY PROCS
#

proc ChooseColorByKey {parent r g b} {
    set w .__tk__color
    upvar ::tk::dialog::color::[winfo name $w] data

    update
    $data(red,entry)   delete 0 end
    $data(green,entry) delete 0 end
    $data(blue,entry)  delete 0 end

    $data(red,entry)   insert 0 $r
    $data(green,entry) insert 0 $g
    $data(blue,entry)  insert 0 $b

    # Manually force the refresh of the color values instead
    # of counting on the timing of the event stream to change
    # the values for us.
    tk::dialog::color::HandleRGBEntry $w

    SendButtonPress . ok mouse
}

proc ToChooseColorByKey {parent r g b} {
    if {! $::dialogIsNative} {
	after 200 ChooseColorByKey . $r $g $b
    }
}

#
# TESTS
#

test clrpick-1.1 {tk_chooseColor command} -body {
    tk_chooseColor -foo
} -returnCodes error -result {bad option "-foo": must be -initialcolor, -parent, or -title}

test clrpick-1.2 {tk_chooseColor command } -body {
    tk_chooseColor -initialcolor
} -returnCodes error -result {value for "-initialcolor" missing}
test clrpick-1.2.1 {tk_chooseColor command } -body {
    tk_chooseColor -parent
} -returnCodes error -result {value for "-parent" missing}
test clrpick-1.2.2 {tk_chooseColor command } -body {
    tk_chooseColor -title
} -returnCodes error -result {value for "-title" missing}

test clrpick-1.3 {tk_chooseColor command} -body {
    tk_chooseColor -foo bar
} -returnCodes error -result {bad option "-foo": must be -initialcolor, -parent, or -title}
test clrpick-1.4 {tk_chooseColor command} -body {
    tk_chooseColor -initialcolor
} -returnCodes error -result {value for "-initialcolor" missing}
test clrpick-1.5 {tk_chooseColor command} -body {
    tk_chooseColor -parent foo.bar
} -returnCodes error -result {bad window path name "foo.bar"}
test clrpick-1.6 {tk_chooseColor command} -body {
    tk_chooseColor -initialcolor badbadbaadcolor
} -returnCodes error -result {unknown color name "badbadbaadcolor"}
test clrpick-1.7 {tk_chooseColor command} -body {
    tk_chooseColor -initialcolor ##badbadbaadcolor
} -returnCodes error -result {invalid color name "##badbadbaadcolor"}

test clrpick-2.1 {tk_chooseColor command} -constraints {
    nonUnixUserInteraction colorsLeftover
} -setup {
    set verylongstring [string repeat longstring: 100]
} -body {
    ToPressButton . ok
    tk_chooseColor -title "Press Ok $verylongstring" -initialcolor #404040 \
	    -parent .
} -result {#404040}
test clrpick-2.2 {tk_chooseColor command} -constraints {
    nonUnixUserInteraction colorsLeftover
} -body {
    set colors "128 128 64"
    ToChooseColorByKey . 128 128 64
    tk_chooseColor -parent . -title "choose #808040"
} -result {#808040}
test clrpick-2.3 {tk_chooseColor command} -constraints {
    nonUnixUserInteraction colorsLeftover
} -body {
    ToPressButton . ok
    tk_chooseColor -parent . -title "Press OK"
} -result {#808040}
test clrpick-2.4 {tk_chooseColor command} -constraints {
    nonUnixUserInteraction colorsLeftover
} -body {
    ToPressButton . cancel
    tk_chooseColor -parent . -title "Press Cancel"
} -result {}


test clrpick-3.1 {tk_chooseColor: background events} -constraints {
	nonUnixUserInteraction
} -body {
    after 1 {set x 53}
    ToPressButton . ok
    tk_chooseColor -parent . -title "Press OK" -initialcolor #000000
} -result {#000000}
test clrpick-3.2 {tk_chooseColor: background events} -constraints {
	nonUnixUserInteraction
} -body {
    after 1 {set x 53}
    ToPressButton . cancel
    tk_chooseColor -parent . -title "Press Cancel"
} -result {}


test clrpick-4.1 {tk_chooseColor: screen is inherited from parent} -constraints {
	unix notAqua
} -body {
    after 50 {set ::scr [winfo screen .__tk__color]}
    ToPressButton . cancel
    tk_chooseColor -parent .
    set ::scr
} -result [winfo screen .]

#
# TESTFILE CLEANUP
#

testutils forget dialog
cleanupTests