summaryrefslogtreecommitdiffstats
path: root/tests/clrpick.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/clrpick.test')
-rw-r--r--tests/clrpick.test215
1 files changed, 215 insertions, 0 deletions
diff --git a/tests/clrpick.test b/tests/clrpick.test
new file mode 100644
index 0000000..d267224
--- /dev/null
+++ b/tests/clrpick.test
@@ -0,0 +1,215 @@
+# 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.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# @(#) clrpick.test 1.9 97/10/21 11:29:53
+#
+
+if {[string compare test [info procs test]] == 1} {
+ source defs
+}
+
+test clrpick-1.1 {tk_chooseColor command} {
+ list [catch {tk_chooseColor -foo} msg] $msg
+} {1 {unknown option "-foo", must be -initialcolor, -parent or -title}}
+
+catch {tk_chooseColor -foo} msg
+regsub -all , $msg "" options
+regsub \"-foo\" $options "" options
+
+foreach option $options {
+ if {[string index $option 0] == "-"} {
+ test clrpick-1.2 {tk_chooseColor command} {
+ list [catch {tk_chooseColor $option} msg] $msg
+ } [list 1 "value for \"$option\" missing"]
+ }
+}
+
+test clrpick-1.3 {tk_chooseColor command} {
+ list [catch {tk_chooseColor -foo bar} msg] $msg
+} {1 {unknown option "-foo", must be -initialcolor, -parent or -title}}
+
+test clrpick-1.4 {tk_chooseColor command} {
+ list [catch {tk_chooseColor -initialcolor} msg] $msg
+} {1 {value for "-initialcolor" missing}}
+
+test clrpick-1.5 {tk_chooseColor command} {
+ list [catch {tk_chooseColor -parent foo.bar} msg] $msg
+} {1 {bad window path name "foo.bar"}}
+
+test clrpick-1.6 {tk_chooseColor command} {
+ list [catch {tk_chooseColor -initialcolor badbadbaadcolor} msg] $msg
+} {1 {unknown color name "badbadbaadcolor"}}
+
+test clrpick-1.7 {tk_chooseColor command} {
+ list [catch {tk_chooseColor -initialcolor ##badbadbaadcolor} msg] $msg
+} {1 {invalid color name "##badbadbaadcolor"}}
+
+if {[info commands tkColorDialog] == ""} {
+ set isNative 1
+} else {
+ set isNative 0
+}
+
+if {$isNative && ![info exists INTERACTIVE]} {
+ puts " Some tests were skipped because they could not be performed"
+ puts " automatically on this platform. If you wish to execute them"
+ puts " interactively, set the TCL variable INTERACTIVE and re-run"
+ puts " the test."
+ return
+}
+
+proc ToPressButton {parent btn} {
+ global isNative
+ if {!$isNative} {
+ after 200 "SendButtonPress $parent $btn mouse"
+ }
+}
+
+proc ToChooseColorByKey {parent r g b} {
+ global isNative
+ if {!$isNative} {
+ after 200 ChooseColorByKey $parent $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 #0 $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.
+ tkColorDialog_HandleRGBEntry $w
+
+ SendButtonPress $parent ok mouse
+}
+
+proc SendButtonPress {parent btn type} {
+ set w .__tk__color
+ upvar #0 $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
+ }
+}
+
+set parent .
+
+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
+
+# let's soak up a bunch of colors...so that
+# machines with small color palettes still fail.
+set numcolors 32
+set nomorecolors 0
+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]"} {
+ set nomorecolors 1
+ }
+ }
+ .c delete $i
+ incr i
+}
+
+destroy .c
+
+if {!$nomorecolors} {
+ set color #404040
+ test clrpick-2.1 {tk_chooseColor command} {
+ ToPressButton $parent ok
+ tk_chooseColor -title "Press Ok $verylongstring" -initialcolor $color -parent $parent
+ } "$color"
+
+ set color #808040
+ test clrpick-2.2 {tk_chooseColor command} {
+ if {$tcl_platform(platform) == "macintosh"} {
+ set colors "32768 32768 16384"
+ } else {
+ set colors "128 128 64"
+ }
+ ToChooseColorByKey $parent 128 128 64
+ tk_chooseColor -parent $parent -title "choose $colors"
+ } "$color"
+
+ test clrpick-2.3 {tk_chooseColor command} {
+ ToPressButton $parent ok
+ tk_chooseColor -parent $parent -title "Press OK"
+ } "$color"
+} else {
+ puts "Skipped tests clrpick2.1, clrpick2.2 and clrpick2.3 because"
+ puts "you ran out of colors in your color palette, and this would"
+ puts "have caused the tests to generate errors."
+}
+
+test clrpick-2.4 {tk_chooseColor command} {
+ ToPressButton $parent cancel
+ tk_chooseColor -parent $parent -title "Press Cancel"
+} ""
+
+set color #000000
+test clrpick-3.1 {tk_chooseColor: background events} {
+ after 1 {set x 53}
+ ToPressButton $parent ok
+ tk_chooseColor -parent $parent -title "Press OK" -initialcolor $color
+} "#000000"
+test clrpick-3.2 {tk_chooseColor: background events} {
+ after 1 {set x 53}
+ ToPressButton $parent cancel
+ tk_chooseColor -parent $parent -title "Press Cancel"
+} ""