diff options
Diffstat (limited to 'tk8.6/tests/color.test')
| -rw-r--r-- | tk8.6/tests/color.test | 282 |
1 files changed, 282 insertions, 0 deletions
diff --git a/tk8.6/tests/color.test b/tk8.6/tests/color.test new file mode 100644 index 0000000..a7ed1f8 --- /dev/null +++ b/tk8.6/tests/color.test @@ -0,0 +1,282 @@ +# 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-1998 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. + +package require tcltest 2.1 +eval tcltest::configure $argv +tcltest::loadTestedCommands + +# 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) +} + +if {[testConstraint psuedocolor8]} { + toplevel .t -visual {pseudocolor 8} -colormap new + wm geom .t +0+0 + mkColors .t.c 40 6 0 0 0 0 6 0 0 0 40 + pack .t.c + update + + testConstraint colorsFree [colorsFree .t.c 101 233 17] + + if {[testConstraint colorsFree]} { + mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0 + pack .t.c2 + testConstraint colorsFree [expr {![colorsFree .t.c]}] + } + destroy .t.c .t.c2 +} + +test color-1.1 {Tk_AllocColorFromObj - converting internal reps} colorsFree { + set x green + lindex $x 0 + destroy .b1 + button .b1 -foreground $x -text .b1 + lindex $x 0 + testcolor green +} {{1 0}} +test color-1.2 {Tk_AllocColorFromObj - discard stale color} colorsFree { + set x green + destroy .b1 .b2 + button .b1 -foreground $x -text First + destroy .b1 + set result {} + lappend result [testcolor green] + button .b2 -foreground $x -text Second + lappend result [testcolor green] +} {{} {{1 1}}} +test color-1.3 {Tk_AllocColorFromObj - reuse existing color} colorsFree { + set x green + destroy .b1 .b2 + button .b1 -foreground $x -text First + set result {} + lappend result [testcolor green] + button .b2 -foreground $x -text Second + pack .b1 .b2 -side top + lappend result [testcolor green] +} {{{1 1}} {{2 1}}} +test color-1.4 {Tk_AllocColorFromObj - try other colors in list} colorsFree { + set x purple + destroy .b1 .b2 .t.b + button .b1 -foreground $x -text First + pack .b1 -side top + set result {} + lappend result [testcolor purple] + button .t.b -foreground $x -text Second + pack .t.b -side top + lappend result [testcolor purple] + button .b2 -foreground $x -text Third + pack .b2 -side top + lappend result [testcolor purple] +} {{{1 1}} {{1 1} {1 0}} {{1 0} {2 1}}} +test color-1.5 {Color table} nonPortable { + set fd [open ../xlib/rgb.txt] + set result {} + while {[gets $fd line] != -1} { + if {[string index $line 0] == "!"} continue + set rgb [c255 [winfo rgb . [lrange $line 3 end]]] + if {$rgb != [lrange $line 0 2] } { + append result $line\n + } + + } + return $result +} {} + +test color-2.1 {Tk_GetColor procedure} colorsFree { + c255 [winfo rgb .t #FF0000] +} {255 0 0} +test color-2.2 {Tk_GetColor procedure} colorsFree { + list [catch {winfo rgb .t noname} msg] $msg +} {1 {unknown color name "noname"}} +test color-2.3 {Tk_GetColor procedure} colorsFree { + c255 [winfo rgb .t #123456] +} {18 52 86} +test color-2.4 {Tk_GetColor procedure} colorsFree { + list [catch {winfo rgb .t #xyz} msg] $msg +} {1 {invalid color name "#xyz"}} +test color-2.5 {Tk_GetColor procedure} colorsFree { + winfo rgb .t #00FF00 +} {0 65535 0} +test color-2.6 {Tk_GetColor procedure} {colorsFree nonPortable} { + # Red doesn't always map to *pure* red + winfo rgb .t red +} {65535 0 0} +test color-2.7 {Tk_GetColor procedure} colorsFree { + winfo rgb .t #ff0000 +} {65535 0 0} + +test color-3.1 {Tk_FreeColor procedure, reference counting} colorsFree { + 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-3.2 {Tk_FreeColor procedure, flushing stressed cmap information} colorsFree { + 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} +test color-3.3 {Tk_FreeColorFromObj - reference counts} colorsFree { + set x purple + destroy .b1 .b2 .t.b + button .b1 -foreground $x -text First + pack .b1 -side top + button .t.b -foreground $x -text Second + pack .t.b -side top + button .b2 -foreground $x -text Third + pack .b2 -side top + set result {} + lappend result [testcolor purple] + destroy .b1 + lappend result [testcolor purple] + destroy .b2 + lappend result [testcolor purple] + destroy .t.b + lappend result [testcolor purple] +} {{{1 0} {2 1}} {{1 0} {1 1}} {{1 0}} {}} +test color-3.4 {Tk_FreeColorFromObj - unlinking from list} colorsFree { + destroy .b .t.b .t2 .t3 + toplevel .t2 -visual {pseudocolor 8} -colormap new + toplevel .t3 -visual {pseudocolor 8} -colormap new + set x purple + button .b -foreground $x -text .b1 + button .t.b1 -foreground $x -text .t.b1 + button .t.b2 -foreground $x -text .t.b2 + button .t2.b1 -foreground $x -text .t2.b1 + button .t2.b2 -foreground $x -text .t2.b2 + button .t2.b3 -foreground $x -text .t2.b3 + button .t3.b1 -foreground $x -text .t3.b1 + button .t3.b2 -foreground $x -text .t3.b2 + button .t3.b3 -foreground $x -text .t3.b3 + button .t3.b4 -foreground $x -text .t3.b4 + set result {} + lappend result [testcolor purple] + destroy .t2 + lappend result [testcolor purple] + destroy .b + lappend result [testcolor purple] + destroy .t3 + lappend result [testcolor purple] + destroy .t + lappend result [testcolor purple] +} {{{4 1} {3 0} {2 0} {1 0}} {{4 1} {2 0} {1 0}} {{4 1} {2 0}} {{2 0}} {}} + +test color-4.1 {FreeColorObjProc} colorsFree { + destroy .b + set x [format purple] + button .b -foreground $x -text .b1 + set y [format purple] + .b configure -foreground $y + set z [format purple] + .b configure -foreground $z + set result {} + lappend result [testcolor purple] + set x red + lappend result [testcolor purple] + set z 32 + lappend result [testcolor purple] + destroy .b + lappend result [testcolor purple] + set y bogus + set result +} {{{1 3}} {{1 2}} {{1 1}} {}} + +destroy .t + +# cleanup +cleanupTests +return |