diff options
Diffstat (limited to 'tests/color.test')
| -rw-r--r-- | tests/color.test | 167 |
1 files changed, 167 insertions, 0 deletions
diff --git a/tests/color.test b/tests/color.test new file mode 100644 index 0000000..030efa0 --- /dev/null +++ b/tests/color.test @@ -0,0 +1,167 @@ +# This file is a Tcl script to test out the procedures in the file +# tkColor.c. It is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1995 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) color.test 1.5 96/02/16 10:56:05 + +if {[info procs test] != "test"} { + source defs +} + +eval destroy [winfo children .] +wm geometry . {} +raise . + +# cname -- +# Returns a proper name for a color, given its intensities. +# +# Arguments: +# r, g, b - Intensities on a 0-255 scale. + +proc cname {r g b} { + format #%02x%02x%02x $r $g $b +} +proc cname4 {r g b} { + format #%04x%04x%04x $r $g $b +} + +# mkColors -- +# Creates a canvas and fills it with a 2-D array of squares, each of a +# different color. +# +# Arguments: +# c - Name of canvas window to create. +# width - Number of squares in each row. +# height - Number of squares in each column. +# r, g, b - Initial value for red, green, and blue intensities. +# rx, gx, bx - Change in intensities between adjacent elements in row. +# ry, gy, by - Change in intensities between adjacent elements in column. + +proc mkColors {c width height r g b rx gx bx ry gy by} { + catch {destroy $c} + canvas $c -width 400 -height 200 -bd 0 + for {set y 0} {$y < $height} {incr y} { + for {set x 0} {$x < $width} {incr x} { + set color [format #%02x%02x%02x [expr $r + $y*$ry + $x*$rx] \ + [expr $g + $y*$gy + $x*$gx] [expr $b + $y*$by + $x*$bx]] + $c create rectangle [expr 10*$x] [expr 20*$y] \ + [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \ + -fill $color + } + } +} + +# closest - +# Given intensities between 0 and 255, return the closest intensities +# that the server can provide. +# +# Arguments: +# w - Window in which to lookup color +# r, g, b - Desired intensities, between 0 and 255. + +proc closest {w r g b} { + set vals [winfo rgb $w [cname $r $g $b]] + list [expr [lindex $vals 0]/256] [expr [lindex $vals 1]/256] \ + [expr [lindex $vals 2]/256] +} + +# c255 - +# Given a list of red, green, and blue intensities, scale them +# down to a 0-255 range. +# +# Arguments: +# vals - List of intensities. + +proc c255 {vals} { + list [expr [lindex $vals 0]/256] [expr [lindex $vals 1]/256] \ + [expr [lindex $vals 2]/256] +} + +# colorsFree -- +# +# Returns 1 if there appear to be free colormap entries in a window, +# 0 otherwise. +# +# Arguments: +# w - Name of window in which to check. +# red, green, blue - Intensities to use in a trial color allocation +# to see if there are colormap entries free. + +proc colorsFree {w {red 31} {green 245} {blue 192}} { + set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]] + expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \ + && ([lindex $vals 2]/256 == $blue) +} + +# Create a top-level with its own colormap (so we can test under +# controlled conditions), then check to make sure that the visual +# is color-mapped with 256 colors. If not, just skip this whole +# test file. + +if [catch {toplevel .t -visual {pseudocolor 8} -colormap new}] { + return +} +wm geom .t +0+0 +if {[winfo depth .t] != 8} { + destroy .t + return +} +mkColors .t.c 40 6 0 0 0 0 6 0 0 0 40 +pack .t.c +update +if ![colorsFree .t.c 101 233 17] { + destroy .t + return +} +mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0 +pack .t.c2 +if [colorsFree .t.c] { + destroy .t + return +} +destroy .t.c .t.c2 + +test color-1.1 {Tk_GetColor procedure} { + c255 [winfo rgb .t red] +} {255 0 0} +test color-1.2 {Tk_GetColor procedure} { + list [catch {winfo rgb .t noname} msg] $msg +} {1 {unknown color name "noname"}} + +test color-1.3 {Tk_GetColor procedure} { + c255 [winfo rgb .t #123456] +} {18 52 86} +test color-1.4 {Tk_GetColor procedure} { + list [catch {winfo rgb .t #xyz} msg] $msg +} {1 {invalid color name "#xyz"}} + +test color-2.1 {Tk_FreeColor procedure, reference counting} { + eval destroy [winfo child .t] + mkColors .t.c 40 6 0 240 240 0 -6 0 0 0 -40 + pack .t.c + mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0 + pack .t.c2 + update + set last [.t.c2 create rectangle 50 50 70 60 -outline {} \ + -fill [cname 0 240 240]] + .t.c delete 1 + set result [colorsFree .t] + .t.c2 delete $last + lappend result [colorsFree .t] +} {0 1} +test color-2.2 {Tk_FreeColor procedure, flushing stressed cmap information} { + eval destroy [winfo child .t] + mkColors .t.c 40 6 0 240 240 0 -6 0 0 0 -40 + pack .t.c + mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0 + mkColors .t.c2 20 1 250 250 0 -10 -10 0 0 0 0 + pack .t.c2 + update + closest .t 241 241 1 +} {240 240 0} + +destroy .t |