--- /dev/null
+# This file is a Tcl script to test out Tk's "tk_chooseColor" command.
+# It is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+namespace import -force tcltest::test
+
+testConstraint failsOnXQuarz [expr {$tcl_platform(os) ne "Darwin" || [tk windowingsystem] ne "x11" }]
+
+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 0
+}
+
+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"}
+
+
+# tests 3.1 and 3.2 fail when individually run
+# if there is no catch {tk_chooseColor -foo 1} msg
+# before settin isNative
+catch {tk_chooseColor -foo 1} msg
+set isNative [expr {[info commands tk::dialog::color::] eq ""}]
+
+proc ToPressButton {parent btn} {
+ global isNative
+ if {!$isNative} {
+ after 200 "SendButtonPress . $btn mouse"
+ }
+}
+
+proc ToChooseColorByKey {parent r g b} {
+ global isNative
+ if {!$isNative} {
+ after 200 ChooseColorByKey . $r $g $b
+ }
+}
+
+proc PressButton {btn} {
+ event generate $btn <Enter>
+ event generate $btn <1> -x 5 -y 5
+ event generate $btn <ButtonRelease-1> -x 5 -y 5
+}
+
+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 SendButtonPress {parent btn type} {
+ set w .__tk__color
+ upvar ::tk::dialog::color::[winfo name $w] data
+
+ set button $data($btn\Btn)
+ if ![winfo ismapped $button] {
+ update
+ }
+
+ if {$type == "mouse"} {
+ PressButton $button
+ } else {
+ event generate $w <Enter>
+ focus $w
+ event generate $button <Enter>
+ event generate $w <KeyPress> -keysym Return
+ }
+}
+
+
+
+test clrpick-2.1 {tk_chooseColor command} -constraints {
+ nonUnixUserInteraction colorsLeftover
+} -setup {
+ set verylongstring longstring:
+ set verylongstring $verylongstring$verylongstring
+ set verylongstring $verylongstring$verylongstring
+ set verylongstring $verylongstring$verylongstring
+ set verylongstring $verylongstring$verylongstring
+ #set verylongstring $verylongstring$verylongstring
+ # Interesting thing...when this is too long, the
+ # delay caused in processing it kills the automated testing,
+ # and makes a lot of the test cases fail.
+ #set verylongstring $verylongstring$verylongstring
+ #set verylongstring $verylongstring$verylongstring
+ #set verylongstring $verylongstring$verylongstring
+ #set verylongstring $verylongstring$verylongstring
+} -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 failsOnXQuarz
+} -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 .]
+
+# cleanup
+cleanupTests
+return
+
OSDN Git Service
