Initial revision

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"
+} ""