1# This file is a Tcl script to test out the procedures in the file
2# tkColor.c.  It is organized in the standard fashion for Tcl tests.
3#
4# Copyright (c) 1995-1998 Sun Microsystems, Inc.
5# Copyright (c) 1998-1999 by Scriptics Corporation.
6# All rights reserved.
7#
8# RCS: @(#) $Id$
9
10package require tcltest 2.1
11eval tcltest::configure $argv
12tcltest::loadTestedCommands
13
14# cname --
15# Returns a proper name for a color, given its intensities.
16#
17# Arguments:
18# r, g, b -	Intensities on a 0-255 scale.
19
20proc cname {r g b} {
21    format #%02x%02x%02x $r $g $b
22}
23proc cname4 {r g b} {
24    format #%04x%04x%04x $r $g $b
25}
26
27# mkColors --
28# Creates a canvas and fills it with a 2-D array of squares, each of a
29# different color.
30#
31# Arguments:
32# c -		Name of canvas window to create.
33# width -	Number of squares in each row.
34# height -	Number of squares in each column.
35# r, g, b -	Initial value for red, green, and blue intensities.
36# rx, gx, bx -	Change in intensities between adjacent elements in row.
37# ry, gy, by -	Change in intensities between adjacent elements in column.
38
39proc mkColors {c width height r g b rx gx bx ry gy by} {
40    catch {destroy $c}
41    canvas $c -width 400 -height 200 -bd 0
42    for {set y 0} {$y < $height} {incr y} {
43	for {set x 0} {$x < $width} {incr x} {
44	    set color [format #%02x%02x%02x [expr $r + $y*$ry + $x*$rx] \
45		    [expr $g + $y*$gy + $x*$gx] [expr $b + $y*$by + $x*$bx]]
46	    $c create rectangle [expr 10*$x] [expr 20*$y] \
47		    [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \
48		    -fill $color
49	}
50    }
51}
52
53# closest -
54# Given intensities between 0 and 255, return the closest intensities
55# that the server can provide.
56#
57# Arguments:
58# w -		Window in which to lookup color
59# r, g, b -	Desired intensities, between 0 and 255.
60
61proc closest {w r g b} {
62    set vals [winfo rgb $w [cname $r $g $b]]
63    list [expr [lindex $vals 0]/256] [expr [lindex $vals 1]/256] \
64	    [expr [lindex $vals 2]/256]
65}
66
67# c255  -
68# Given a list of red, green, and blue intensities, scale them
69# down to a 0-255 range.
70#
71# Arguments:
72# vals -	List of intensities.
73
74proc c255 {vals} {
75    list [expr [lindex $vals 0]/256] [expr [lindex $vals 1]/256] \
76	    [expr [lindex $vals 2]/256]
77}
78
79# colorsFree --
80#
81# Returns 1 if there appear to be free colormap entries in a window,
82# 0 otherwise.
83#
84# Arguments:
85# w -			Name of window in which to check.
86# red, green, blue -	Intensities to use in a trial color allocation
87#			to see if there are colormap entries free.
88
89proc colorsFree {w {red 31} {green 245} {blue 192}} {
90    set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]]
91    expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \
92	    && ([lindex $vals 2]/256 == $blue)
93}
94
95if {[testConstraint psuedocolor8]} {
96    toplevel .t -visual {pseudocolor 8} -colormap new
97    wm geom .t +0+0
98    mkColors .t.c 40 6 0 0 0 0 6 0 0 0 40
99    pack .t.c
100    update
101
102    testConstraint colorsFree [colorsFree .t.c 101 233 17]
103
104    if {[testConstraint colorsFree]} {
105	mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0
106	pack .t.c2
107	testConstraint colorsFree [expr {![colorsFree .t.c]}]
108    }
109    destroy .t.c .t.c2
110}
111
112test color-1.1 {Tk_AllocColorFromObj - converting internal reps} colorsFree {
113    set x green
114    lindex $x 0
115    destroy .b1
116    button .b1 -foreground $x -text .b1
117    lindex $x 0
118    testcolor green
119} {{1 0}}
120test color-1.2 {Tk_AllocColorFromObj - discard stale color} colorsFree {
121    set x green
122    destroy .b1 .b2
123    button .b1 -foreground $x -text First
124    destroy .b1
125    set result {}
126    lappend result [testcolor green]
127    button .b2 -foreground $x -text Second
128    lappend result [testcolor green]
129} {{} {{1 1}}}
130test color-1.3 {Tk_AllocColorFromObj - reuse existing color} colorsFree {
131    set x green
132    destroy .b1 .b2
133    button .b1 -foreground $x -text First
134    set result {}
135    lappend result [testcolor green]
136    button .b2 -foreground $x -text Second
137    pack .b1 .b2 -side top
138    lappend result [testcolor green]
139} {{{1 1}} {{2 1}}}
140test color-1.4 {Tk_AllocColorFromObj - try other colors in list} colorsFree {
141    set x purple
142    destroy .b1 .b2 .t.b
143    button .b1 -foreground $x -text First
144    pack .b1 -side top
145    set result {}
146    lappend result [testcolor purple]
147    button .t.b -foreground $x -text Second
148    pack .t.b -side top
149    lappend result [testcolor purple]
150    button .b2 -foreground $x -text Third
151    pack .b2 -side top
152    lappend result [testcolor purple]
153} {{{1 1}} {{1 1} {1 0}} {{1 0} {2 1}}}
154
155test color-2.1 {Tk_GetColor procedure} colorsFree {
156    c255 [winfo rgb .t #FF0000]
157} {255 0 0}
158test color-2.2 {Tk_GetColor procedure} colorsFree {
159    list [catch {winfo rgb .t noname} msg] $msg
160} {1 {unknown color name "noname"}}
161test color-2.3 {Tk_GetColor procedure} colorsFree {
162    c255 [winfo rgb .t #123456]
163} {18 52 86}
164test color-2.4 {Tk_GetColor procedure} colorsFree {
165    list [catch {winfo rgb .t #xyz} msg] $msg
166} {1 {invalid color name "#xyz"}}
167test color-2.5 {Tk_GetColor procedure} colorsFree {
168    winfo rgb .t #00FF00
169} {0 65535 0}
170test color-2.6 {Tk_GetColor procedure} {colorsFree nonPortable} {
171    # Red doesn't always map to *pure* red
172    winfo rgb .t red
173} {65535 0 0}
174test color-2.7 {Tk_GetColor procedure} colorsFree {
175    winfo rgb .t #ff0000
176} {65535 0 0}
177
178test color-3.1 {Tk_FreeColor procedure, reference counting} colorsFree {
179    eval destroy [winfo child .t]
180    mkColors .t.c 40 6 0 240 240 0 -6 0 0 0 -40
181    pack .t.c
182    mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0
183    pack .t.c2
184    update
185    set last [.t.c2 create rectangle 50 50 70 60 -outline {} \
186	    -fill [cname 0 240 240]]
187    .t.c delete 1
188    set result [colorsFree .t]
189    .t.c2 delete $last
190    lappend result [colorsFree .t]
191} {0 1}
192test color-3.2 {Tk_FreeColor procedure, flushing stressed cmap information} colorsFree {
193    eval destroy [winfo child .t]
194    mkColors .t.c 40 6 0 240 240 0 -6 0 0 0 -40
195    pack .t.c
196    mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0
197    mkColors .t.c2 20 1 250 250 0 -10 -10 0 0 0 0
198    pack .t.c2
199    update
200    closest .t 241 241 1
201} {240 240 0}
202test color-3.3 {Tk_FreeColorFromObj - reference counts} colorsFree {
203    set x purple
204    destroy .b1 .b2 .t.b
205    button .b1 -foreground $x -text First
206    pack .b1 -side top
207    button .t.b -foreground $x -text Second
208    pack .t.b -side top
209    button .b2 -foreground $x -text Third
210    pack .b2 -side top
211    set result {}
212    lappend result [testcolor purple]
213    destroy .b1
214    lappend result [testcolor purple]
215    destroy .b2
216    lappend result [testcolor purple]
217    destroy .t.b
218    lappend result [testcolor purple]
219} {{{1 0} {2 1}} {{1 0} {1 1}} {{1 0}} {}}
220test color-3.4 {Tk_FreeColorFromObj - unlinking from list} colorsFree {
221    destroy .b .t.b .t2 .t3
222    toplevel .t2 -visual {pseudocolor 8} -colormap new
223    toplevel .t3 -visual {pseudocolor 8} -colormap new
224    set x purple
225    button .b -foreground $x -text .b1
226    button .t.b1 -foreground $x -text .t.b1
227    button .t.b2 -foreground $x -text .t.b2
228    button .t2.b1 -foreground $x -text .t2.b1
229    button .t2.b2 -foreground $x -text .t2.b2
230    button .t2.b3 -foreground $x -text .t2.b3
231    button .t3.b1 -foreground $x -text .t3.b1
232    button .t3.b2 -foreground $x -text .t3.b2
233    button .t3.b3 -foreground $x -text .t3.b3
234    button .t3.b4 -foreground $x -text .t3.b4
235    set result {}
236    lappend result [testcolor purple]
237    destroy .t2
238    lappend result [testcolor purple]
239    destroy .b
240    lappend result [testcolor purple]
241    destroy .t3
242    lappend result [testcolor purple]
243    destroy .t
244    lappend result [testcolor purple]
245} {{{4 1} {3 0} {2 0} {1 0}} {{4 1} {2 0} {1 0}} {{4 1} {2 0}} {{2 0}} {}}
246
247test color-4.1 {FreeColorObjProc} colorsFree {
248    destroy .b
249    set x [format purple]
250    button .b -foreground $x -text .b1
251    set y [format purple]
252    .b configure -foreground $y
253    set z [format purple]
254    .b configure -foreground $z
255    set result {}
256    lappend result [testcolor purple]
257    set x red
258    lappend result [testcolor purple]
259    set z 32
260    lappend result [testcolor purple]
261    destroy .b
262    lappend result [testcolor purple]
263    set y bogus
264    set result
265} {{{1 3}} {{1 2}} {{1 1}} {}}
266
267destroy .t
268
269# cleanup
270cleanupTests
271return
272