Initial revision

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