1# This file is a Tcl script to test the visual- and colormap-handling
2# procedures in the file tkVisual.c.  It is organized in the standard
3# fashion for Tcl tests.
4#
5# Copyright (c) 1994 The Regents of the University of California.
6# Copyright (c) 1994-1995 Sun Microsystems, Inc.
7# Copyright (c) 1998-1999 by Scriptics Corporation.
8# All rights reserved.
9#
10# RCS: @(#) $Id$
11
12package require tcltest 2.1
13eval tcltest::configure $argv
14tcltest::loadTestedCommands
15
16update
17
18# eatColors --
19# Creates a toplevel window and allocates enough colors in it to
20# use up all the slots in the colormap.
21#
22# Arguments:
23# w -		Name of toplevel window to create.
24
25proc eatColors {w} {
26    catch {destroy $w}
27    toplevel $w
28    wm geom $w +0+0
29    canvas $w.c -width 400 -height 200 -bd 0
30    pack $w.c
31    for {set y 0} {$y < 8} {incr y} {
32	for {set x 0} {$x < 40} {incr x} {
33	    set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0]
34	    $w.c create rectangle [expr 10*$x] [expr 20*$y] \
35		    [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \
36		    -fill $color
37	}
38    }
39    update
40}
41
42# colorsFree --
43#
44# Returns 1 if there appear to be free colormap entries in a window,
45# 0 otherwise.
46#
47# Arguments:
48# w -			Name of window in which to check.
49# red, green, blue -	Intensities to use in a trial color allocation
50#			to see if there are colormap entries free.
51
52proc colorsFree {w {red 31} {green 245} {blue 192}} {
53    set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]]
54    expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \
55	    && ([lindex $vals 2]/256 == $blue)
56}
57
58# If more than one visual type is available for the screen, pick one
59# that is *not* the default.
60
61set default "[winfo visual .] [winfo depth .]"
62set avail [winfo visualsavailable .]
63set other {}
64if {[llength $avail] > 1} {
65    foreach visual $avail {
66	if {$visual != $default} {
67	    set other $visual
68	    break
69	}
70    }
71}
72testConstraint haveOtherVisual [expr {$other ne ""}]
73testConstraint havePseudocolorVisual [string match *pseudocolor* $avail]
74testConstraint haveMultipleVisuals [expr {[llength $avail] > 1}]
75
76test visual-1.1 {Tk_GetVisual, copying from other window} {
77    list [catch {toplevel .t -visual .foo.bar} msg] $msg
78} {1 {bad window path name ".foo.bar"}}
79test visual-1.2 {Tk_GetVisual, copying from other window} {haveOtherVisual nonPortable} {
80    catch {destroy .t1}
81    catch {destroy .t2}
82    toplevel .t1 -width 250 -height 100 -visual $other
83    wm geom .t1 +0+0
84    toplevel .t2 -width 200 -height 80 -visual .t1
85    wm geom .t2 +5+5
86    concat "[winfo visual .t2] [winfo depth .t2]"
87} $other
88test visual-1.3 {Tk_GetVisual, copying from other window} haveOtherVisual {
89    catch {destroy .t1}
90    catch {destroy .t2}
91    toplevel .t1 -width 250 -height 100 -visual $other
92    wm geom .t1 +0+0
93    toplevel .t2 -width 200 -height 80 -visual .
94    wm geom .t2 +5+5
95    concat "[winfo visual .t2] [winfo depth .t2]"
96} $default
97# Make sure reference count is incremented when copying visual (the
98# following test will cause the colormap to be freed prematurely if
99# the reference count isn't incremented).
100test visual-1.4 {Tk_GetVisual, colormap reference count} haveOtherVisual {
101    catch {destroy .t1}
102    catch {destroy .t2}
103    toplevel .t1 -width 250 -height 100 -visual $other
104    wm geom .t1 +0+0
105    set result [list [catch {toplevel .t2 -gorp 80 -visual .t1} msg] $msg]
106    update
107    set result
108} {1 {unknown option "-gorp"}}
109test visual-1.5 {Tk_GetVisual, default colormap} {
110    catch {destroy .t1}
111    toplevel .t1 -width 250 -height 100 -visual default
112    wm geometry .t1 +0+0
113    update
114    concat "[winfo visual .t1] [winfo depth .t1]"
115} $default
116
117set i 1
118foreach visual $avail {
119    test visual-2.$i {Tk_GetVisual, different visual types} {nonPortable} {
120	catch {destroy .t1}
121	toplevel .t1 -width 250 -height 100 -visual $visual
122	wm geometry .t1 +0+0
123	update
124	concat "[winfo visual .t1] [winfo depth .t1]"
125    } $visual
126    incr i
127}
128
129test visual-3.1 {Tk_GetVisual, parsing visual string} {
130    catch {destroy .t1}
131    toplevel .t1 -width 250 -height 100 \
132	    -visual "[winfo visual .][winfo depth .]"
133    wm geometry .t1 +0+0
134    update
135    concat "[winfo visual .t1] [winfo depth .t1]"
136} $default
137test visual-3.2 {Tk_GetVisual, parsing visual string} {
138    catch {destroy .t1}
139    list [catch {
140	toplevel .t1 -width 250 -height 100 -visual goop20
141	wm geometry .t1 +0+0
142    } msg] $msg
143} {1 {unknown or ambiguous visual name "goop20": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}}
144test visual-3.3 {Tk_GetVisual, parsing visual string} {
145    catch {destroy .t1}
146    list [catch {
147	toplevel .t1 -width 250 -height 100 -visual d
148	wm geometry .t1 +0+0
149    } msg] $msg
150} {1 {unknown or ambiguous visual name "d": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}}
151test visual-3.4 {Tk_GetVisual, parsing visual string} {
152    catch {destroy .t1}
153    list [catch {
154	toplevel .t1 -width 250 -height 100 -visual static
155	wm geometry .t1 +0+0
156    } msg] $msg
157} {1 {unknown or ambiguous visual name "static": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}}
158test visual-3.5 {Tk_GetVisual, parsing visual string} {
159    catch {destroy .t1}
160    list [catch {
161	toplevel .t1 -width 250 -height 100 -visual "pseudocolor 48x"
162	wm geometry .t1 +0+0
163    } msg] $msg
164} {1 {expected integer but got "48x"}}
165
166test visual-4.1 {Tk_GetVisual, numerical visual id} -setup {
167    catch {destroy .t1}
168    catch {destroy .t2}
169    catch {destroy .t3}
170    toplevel .t1 -width 250 -height 100 -visual $other
171    wm geom .t1 +0+0
172    toplevel .t2 -width 200 -height 80 -visual [winfo visual .]
173    wm geom .t2 +5+5
174    toplevel .t3 -width 150 -height 250 -visual [winfo visual .t1]
175    wm geom .t3 +10+10
176} -constraints {haveOtherVisual nonPortable} -body {
177    set v1 [list [winfo visualid .t2] [winfo visualid .t3]]
178    set v2 [list [winfo visualid .] [winfo visualid .t1]]
179    expr {$v1 eq $v2 ? "OK" : "[list $v1] ne [list $v2]"}
180} -result OK -cleanup {
181    destroy .t1 .t2 .t3
182}
183test visual-4.2 {Tk_GetVisual, numerical visual id} {
184    catch {destroy .t1}
185    list [catch {toplevel .t1 -visual 12xyz} msg] $msg
186} {1 {bad X identifier for visual: "12xyz"}}
187test visual-4.3 {Tk_GetVisual, numerical visual id} {
188    catch {destroy .t1}
189    list [catch {toplevel .t1 -visual 1291673} msg] $msg
190} {1 {couldn't find an appropriate visual}}
191
192test visual-5.1 {Tk_GetVisual, no matching visual} !havePseudocolorVisual {
193    catch {destroy .t1}
194    list [catch {
195	toplevel .t1 -width 250 -height 100 -visual "pseudocolor 8"
196	wm geometry .t1 +0+0
197    } msg] $msg
198} {1 {couldn't find an appropriate visual}}
199
200test visual-6.1 {Tk_GetVisual, no matching visual} {havePseudocolorVisual haveMultipleVisuals nonPortable} {
201    catch {destroy .t1}
202    toplevel .t1 -width 250 -height 100 -visual "best"
203    wm geometry .t1 +0+0
204    update
205    winfo visual .t1
206} {pseudocolor}
207
208# These tests are non-portable due to variations in how many colors
209# are already in use on the screen.
210
211if {[testConstraint defaultPseudocolor8]} {
212    eatColors .t1
213}
214test visual-7.1 {Tk_GetColormap, "new"} {defaultPseudocolor8 nonPortable} {
215    toplevel .t2 -width 30 -height 20
216    wm geom .t2 +0+0
217    update
218    colorsFree .t2
219} {0}
220test visual-7.2 {Tk_GetColormap, "new"} {defaultPseudocolor8 nonPortable} {
221    catch {destroy .t2}
222    toplevel .t2 -width 30 -height 20 -colormap new
223    wm geom .t2 +0+0
224    update
225    colorsFree .t2
226} {1}
227test visual-7.3 {Tk_GetColormap, copy from other window} {defaultPseudocolor8 nonPortable} {
228    catch {destroy .t2}
229    toplevel .t3 -width 400 -height 50 -colormap new
230    wm geom .t3 +0+0
231    catch {destroy .t2}
232    toplevel .t2 -width 30 -height 20 -colormap .t3
233    wm geom .t2 +0+0
234    update
235    destroy .t3
236    colorsFree .t2
237} {1}
238test visual-7.4 {Tk_GetColormap, copy from other window} {defaultPseudocolor8 nonPortable} {
239    catch {destroy .t2}
240    toplevel .t3 -width 400 -height 50 -colormap new
241    wm geom .t3 +0+0
242    catch {destroy .t2}
243    toplevel .t2 -width 30 -height 20 -colormap .
244    wm geom .t2 +0+0
245    update
246    destroy .t3
247    colorsFree .t2
248} {0}
249test visual-7.5 {Tk_GetColormap, copy from other window} {defaultPseudocolor8 nonPortable} {
250    catch {destroy .t1}
251    list [catch {
252	toplevel .t1 -width 400 -height 50 -colormap .choke.lots
253    } msg] $msg
254} {1 {bad window path name ".choke.lots"}}
255test visual-7.6 {Tk_GetColormap, copy from other window} {defaultPseudocolor8 haveOtherVisual nonPortable} {
256    catch {destroy .t1}
257    catch {destroy .t2}
258    toplevel .t1 -width 300 -height 150 -visual $other
259    wm geometry .t1 +0+0
260    list [catch {toplevel .t2 -width 400 -height 50 -colormap .t1} msg] $msg
261} {1 {can't use colormap for .t1: incompatible visuals}}
262if {[testConstraint defaultPseudocolor8]} {
263    catch {destroy .t1}
264    catch {destroy .t2}
265}
266
267test visual-8.1 {Tk_FreeColormap procedure} {
268    deleteWindows
269    toplevel .t1 -width 300 -height 180 -colormap new
270    wm geometry .t1 +0+0
271    foreach i {.t2 .t3 .t4} {
272	toplevel $i -width 250 -height 150 -colormap .t1
273	wm geometry $i +0+0
274    }
275    destroy .t1
276    destroy .t3
277    destroy .t4
278    update
279} {}
280test visual-8.2 {Tk_FreeColormap procedure} haveOtherVisual {
281    deleteWindows
282    toplevel .t1 -width 300 -height 180 -visual $other
283    wm geometry .t1 +0+0
284    foreach i {.t2 .t3 .t4} {
285	toplevel $i -width 250 -height 150 -visual $other
286	wm geometry $i +0+0
287    }
288    destroy .t2
289    destroy .t3
290    destroy .t4
291    update
292} {}
293
294deleteWindows
295rename eatColors {}
296rename colorsFree {}
297
298# cleanup
299cleanupTests
300return
301