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