1# This file is a Tcl script to test out Tk's "tk_chooseColor" command.
2# It is organized in the standard fashion for Tcl tests.
3#
4# Copyright (c) 1996 Sun Microsystems, Inc.
5# Copyright (c) 1998-1999 by Scriptics Corporation.
6# All rights reserved.
7#
8# RCS: @(#) $Id$
9#
10
11package require tcltest 2.1
12eval tcltest::configure $argv
13tcltest::loadTestedCommands
14
15if {[testConstraint defaultPseudocolor8]} {
16    # let's soak up a bunch of colors...so that
17    # machines with small color palettes still fail.
18    # some tests will be skipped if there are no more colors
19    set numcolors 32
20    testConstraint colorsLeftover 1
21    set i 0
22    canvas .c
23    pack .c -expand 1 -fill both
24    while {$i<$numcolors} {
25	set color \#[format "%02x%02x%02x" $i [expr $i+1] [expr $i+3]]
26	.c create rectangle [expr 10+$i] [expr 10+$i] [expr 50+$i] [expr 50+$i] -fill $color -outline $color
27	incr i
28    }
29    set i 0
30    while {$i<$numcolors} {
31	set color [.c itemcget $i -fill]
32	if {$color != ""} {
33	    foreach {r g b} [winfo rgb . $color] {}
34	    set r [expr $r/256]
35	    set g [expr $g/256]
36	    set b [expr $b/256]
37	    if {"$color" != "#[format %02x%02x%02x $r $g $b]"} {
38		testConstraint colorsLeftover 0
39	    }
40	}
41	.c delete $i
42	incr i
43    }
44    destroy .c
45} else {
46    testConstraint colorsLeftover 0
47}
48
49test clrpick-1.1 {tk_chooseColor command} {
50    list [catch {tk_chooseColor -foo} msg] $msg
51} {1 {bad option "-foo": must be -initialcolor, -parent, or -title}}
52
53catch {tk_chooseColor -foo 1} msg
54regsub -all ,      $msg "" options
55regsub \"-foo\" $options "" options
56
57foreach option $options {
58    if {[string index $option 0] eq "-"} {
59	test clrpick-1.2$option {tk_chooseColor command} -body {
60	    tk_chooseColor $option
61	} -returnCodes error -result "value for \"$option\" missing"
62    }
63}
64
65test clrpick-1.3 {tk_chooseColor command} {
66    list [catch {tk_chooseColor -foo bar} msg] $msg
67} {1 {bad option "-foo": must be -initialcolor, -parent, or -title}}
68test clrpick-1.4 {tk_chooseColor command} {
69    list [catch {tk_chooseColor -initialcolor} msg] $msg
70} {1 {value for "-initialcolor" missing}}
71test clrpick-1.5 {tk_chooseColor command} {
72    list [catch {tk_chooseColor -parent foo.bar} msg] $msg
73} {1 {bad window path name "foo.bar"}}
74test clrpick-1.6 {tk_chooseColor command} {
75    list [catch {tk_chooseColor -initialcolor badbadbaadcolor} msg] $msg
76} {1 {unknown color name "badbadbaadcolor"}}
77test clrpick-1.7 {tk_chooseColor command} {
78    list [catch {tk_chooseColor -initialcolor ##badbadbaadcolor} msg] $msg
79} {1 {invalid color name "##badbadbaadcolor"}}
80
81set isNative [expr {[info commands tk::dialog::color::] eq ""}]
82
83proc ToPressButton {parent btn} {
84    global isNative
85    if {!$isNative} {
86	after 200 "SendButtonPress $parent $btn mouse"
87    }
88}
89
90proc ToChooseColorByKey {parent r g b} {
91    global isNative
92    if {!$isNative} {
93	after 200 ChooseColorByKey $parent $r $g $b
94    }
95}
96
97proc PressButton {btn} {
98    event generate $btn <Enter>
99    event generate $btn <1> -x 5 -y 5
100    event generate $btn <ButtonRelease-1> -x 5 -y 5
101}
102
103proc ChooseColorByKey {parent r g b} {
104    set w .__tk__color
105    upvar ::tk::dialog::color::[winfo name $w] data
106
107    update
108    $data(red,entry)   delete 0 end
109    $data(green,entry) delete 0 end
110    $data(blue,entry)  delete 0 end
111
112    $data(red,entry)   insert 0 $r
113    $data(green,entry) insert 0 $g
114    $data(blue,entry)  insert 0 $b
115
116    # Manually force the refresh of the color values instead
117    # of counting on the timing of the event stream to change
118    # the values for us.
119    tk::dialog::color::HandleRGBEntry $w
120
121    SendButtonPress $parent ok mouse
122}
123
124proc SendButtonPress {parent btn type} {
125    set w .__tk__color
126    upvar ::tk::dialog::color::[winfo name $w] data
127
128    set button $data($btn\Btn)
129    if ![winfo ismapped $button] {
130	update
131    }
132
133    if {$type == "mouse"} {
134	PressButton $button
135    } else {
136	event generate $w <Enter>
137	focus $w
138	event generate $button <Enter>
139	event generate $w <KeyPress> -keysym Return
140    }
141}
142
143set parent .
144
145set verylongstring longstring:
146set verylongstring $verylongstring$verylongstring
147set verylongstring $verylongstring$verylongstring
148set verylongstring $verylongstring$verylongstring
149set verylongstring $verylongstring$verylongstring
150#set verylongstring $verylongstring$verylongstring
151# Interesting thing...when this is too long, the
152# delay caused in processing it kills the automated testing,
153# and makes a lot of the test cases fail.
154#set verylongstring $verylongstring$verylongstring
155#set verylongstring $verylongstring$verylongstring
156#set verylongstring $verylongstring$verylongstring
157#set verylongstring $verylongstring$verylongstring
158
159set color #404040
160test clrpick-2.1 {tk_chooseColor command} \
161	{nonUnixUserInteraction colorsLeftover} {
162    ToPressButton $parent ok
163    tk_chooseColor -title "Press Ok $verylongstring" -initialcolor $color \
164	    -parent $parent
165} "$color"
166set color #808040
167test clrpick-2.2 {tk_chooseColor command} \
168	{nonUnixUserInteraction colorsLeftover} {
169    set colors "128 128 64"
170    ToChooseColorByKey $parent 128 128 64
171    tk_chooseColor -parent $parent -title "choose $colors"
172} "$color"
173test clrpick-2.3 {tk_chooseColor command} \
174	{nonUnixUserInteraction colorsLeftover} {
175    ToPressButton $parent ok
176    tk_chooseColor -parent $parent -title "Press OK"
177} "$color"
178test clrpick-2.4 {tk_chooseColor command} {nonUnixUserInteraction} {
179    ToPressButton $parent cancel
180    tk_chooseColor -parent $parent -title "Press Cancel"
181} ""
182
183set color "#000000"
184test clrpick-3.1 {tk_chooseColor: background events} {nonUnixUserInteraction} {
185    after 1 {set x 53}
186    ToPressButton $parent ok
187    tk_chooseColor -parent $parent -title "Press OK" -initialcolor $color
188} "#000000"
189test clrpick-3.2 {tk_chooseColor: background events} {nonUnixUserInteraction} {
190    after 1 {set x 53}
191    ToPressButton $parent cancel
192    tk_chooseColor -parent $parent -title "Press Cancel"
193} ""
194
195test clrpick-4.1 {tk_chooseColor: screen is inherited from parent} {unix notAqua} {
196    after 50 {set ::scr [winfo screen .__tk__color]}
197    ToPressButton $parent cancel
198    tk_chooseColor -parent $parent
199    set ::scr
200} [winfo screen $parent]
201
202# cleanup
203cleanupTests
204return
205