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