summaryrefslogtreecommitdiffstats
path: root/tests/color.test
diff options
context:
space:
mode:
authorstanton <stanton>1999-04-16 01:51:06 (GMT)
committerstanton <stanton>1999-04-16 01:51:06 (GMT)
commit03656f44f81469f459031fa3a4a7b09c8bc77712 (patch)
tree31378e81bd58f8c726fc552d6b30cbf3ca07497b /tests/color.test
parent404fc236f34304df53b7e44bc7971d786b87d453 (diff)
downloadtk-03656f44f81469f459031fa3a4a7b09c8bc77712.zip
tk-03656f44f81469f459031fa3a4a7b09c8bc77712.tar.gz
tk-03656f44f81469f459031fa3a4a7b09c8bc77712.tar.bz2
* Merged 8.1 branch into the main trunk
Diffstat (limited to 'tests/color.test')
-rw-r--r--tests/color.test162
1 files changed, 147 insertions, 15 deletions
diff --git a/tests/color.test b/tests/color.test
index 7c68ec3..3b86efc 100644
--- a/tests/color.test
+++ b/tests/color.test
@@ -1,15 +1,20 @@
# 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.
+# Copyright (c) 1995-1998 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: color.test,v 1.2 1998/09/14 18:23:45 stanton Exp $
+# RCS: @(#) $Id: color.test,v 1.3 1999/04/16 01:51:36 stanton Exp $
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
-if {[info procs test] != "test"} {
- source defs
+if {[info commands testcolor] != "testcolor"} {
+ puts "testcolor command not available; skipping tests"
+ ::tcltest::cleanupTests
+ return
}
eval destroy [winfo children .]
@@ -103,11 +108,13 @@ proc colorsFree {w {red 31} {green 245} {blue 192}} {
# test file.
if [catch {toplevel .t -visual {pseudocolor 8} -colormap new}] {
+ ::tcltest::cleanupTests
return
}
wm geom .t +0+0
if {[winfo depth .t] != 8} {
destroy .t
+ ::tcltest::cleanupTests
return
}
mkColors .t.c 40 6 0 0 0 0 6 0 0 0 40
@@ -115,31 +122,75 @@ pack .t.c
update
if ![colorsFree .t.c 101 233 17] {
destroy .t
+ ::tcltest::cleanupTests
return
}
mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0
pack .t.c2
if [colorsFree .t.c] {
destroy .t
+ ::tcltest::cleanupTests
return
}
destroy .t.c .t.c2
-test color-1.1 {Tk_GetColor procedure} {
- c255 [winfo rgb .t red]
+test color-1.1 {Tk_AllocColorFromObj - converting internal reps} {
+ 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} {
+ 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} {
+ 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} {
+ 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-2.1 {Tk_GetColor procedure} {
+ c255 [winfo rgb .t #FF0000]
} {255 0 0}
-test color-1.2 {Tk_GetColor procedure} {
+test color-2.2 {Tk_GetColor procedure} {
list [catch {winfo rgb .t noname} msg] $msg
} {1 {unknown color name "noname"}}
-
-test color-1.3 {Tk_GetColor procedure} {
+test color-2.3 {Tk_GetColor procedure} {
c255 [winfo rgb .t #123456]
} {18 52 86}
-test color-1.4 {Tk_GetColor procedure} {
+test color-2.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} {
+test color-3.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
@@ -153,7 +204,7 @@ test color-2.1 {Tk_FreeColor procedure, reference counting} {
.t.c2 delete $last
lappend result [colorsFree .t]
} {0 1}
-test color-2.2 {Tk_FreeColor procedure, flushing stressed cmap information} {
+test color-3.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
@@ -163,5 +214,86 @@ test color-2.2 {Tk_FreeColor procedure, flushing stressed cmap information} {
update
closest .t 241 241 1
} {240 240 0}
+test color-3.3 {Tk_FreeColorFromObj - reference counts} {
+ 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} {
+ 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} {
+ 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
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+