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