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