Initial revision

1 files changed, 312 insertions, 0 deletions

diff --git a/tests/visual.test b/tests/visual.test
new file mode 100644
index 0000000..853554e
--- /dev/null
+++ b/tests/visual.test
@@ -0,0 +1,312 @@
+# This file is a Tcl script to test the visual- and colormap-handling
+# procedures in the file tkVisual.c.  It is organized in the standard
+# fashion for Tcl tests.
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994-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: @(#) visual.test 1.11 96/02/16 10:55:34
+
+if {[info procs test] != "test"} {
+    source defs
+}
+
+foreach i [winfo children .] {
+    destroy $i
+}
+wm geometry . {}
+raise .
+update
+
+# eatColors --
+# Creates a toplevel window and allocates enough colors in it to
+# use up all the slots in the colormap.
+#
+# Arguments:
+# w -		Name of toplevel window to create.
+
+proc eatColors {w} {
+    catch {destroy $w}
+    toplevel $w
+    wm geom $w +0+0
+    canvas $w.c -width 400 -height 200 -bd 0
+    pack $w.c
+    for {set y 0} {$y < 8} {incr y} {
+	for {set x 0} {$x < 40} {incr x} {
+	    set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0]
+	    $w.c create rectangle [expr 10*$x] [expr 20*$y] \
+		    [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \
+		    -fill $color
+	}
+    }
+    update
+}
+
+# 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 more than one visual type is available for the screen, pick one
+# that is *not* the default.
+
+set default "[winfo visual .] [winfo depth .]"
+set avail [winfo visualsavailable .]
+set other {}
+if {[llength $avail] > 1} {
+    foreach visual $avail {
+	if {$visual != $default} {
+	    set other $visual
+	    break
+	}
+    }
+}
+
+test visual-1.1 {Tk_GetVisual, copying from other window} {
+    list [catch {toplevel .t -visual .foo.bar} msg] $msg
+} {1 {bad window path name ".foo.bar"}}
+if {$other != ""} {
+    test visual-1.2 {Tk_GetVisual, copying from other window} {nonPortable} {
+	catch {destroy .t1}
+	catch {destroy .t2}
+	toplevel .t1 -width 250 -height 100 -visual $other
+	wm geom .t1 +0+0
+	toplevel .t2 -width 200 -height 80 -visual .t1
+	wm geom .t2 +5+5
+	concat "[winfo visual .t2] [winfo depth .t2]"
+    } $other
+    test visual-1.3 {Tk_GetVisual, copying from other window} {
+	catch {destroy .t1}
+	catch {destroy .t2}
+	toplevel .t1 -width 250 -height 100 -visual $other
+	wm geom .t1 +0+0
+	toplevel .t2 -width 200 -height 80 -visual .
+	wm geom .t2 +5+5
+	concat "[winfo visual .t2] [winfo depth .t2]"
+    } $default
+
+    # Make sure reference count is incremented when copying visual (the
+    # following test will cause the colormap to be freed prematurely if
+    # the reference count isn't incremented).
+    test visual-1.4 {Tk_GetVisual, colormap reference count} {
+	catch {destroy .t1}
+	catch {destroy .t2}
+	toplevel .t1 -width 250 -height 100 -visual $other
+	wm geom .t1 +0+0
+	set result [list [catch {toplevel .t2 -gorp 80 -visual .t1} msg] $msg]
+	update
+	set result
+    } {1 {unknown option "-gorp"}}
+}
+test visual-1.5 {Tk_GetVisual, default colormap} {
+    catch {destroy .t1}
+    toplevel .t1 -width 250 -height 100 -visual default
+    wm geometry .t1 +0+0
+    update
+    concat "[winfo visual .t1] [winfo depth .t1]"
+} $default
+
+set i 1
+foreach visual $avail {
+    test visual-2.$i {Tk_GetVisual, different visual types} {nonPortable} {
+	catch {destroy .t1}
+	toplevel .t1 -width 250 -height 100 -visual $visual
+	wm geometry .t1 +0+0
+	update
+	concat "[winfo visual .t1] [winfo depth .t1]"
+    } $visual
+    incr i
+}
+
+test visual-3.1 {Tk_GetVisual, parsing visual string} {
+    catch {destroy .t1}
+    toplevel .t1 -width 250 -height 100 \
+	    -visual "[winfo visual .][winfo depth .]"
+    wm geometry .t1 +0+0
+    update
+    concat "[winfo visual .t1] [winfo depth .t1]"
+} $default
+test visual-3.2 {Tk_GetVisual, parsing visual string} {
+    catch {destroy .t1}
+    list [catch {
+	toplevel .t1 -width 250 -height 100 -visual goop20
+	wm geometry .t1 +0+0
+    } msg] $msg
+} {1 {unknown or ambiguous visual name "goop20": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}}
+test visual-3.3 {Tk_GetVisual, parsing visual string} {
+    catch {destroy .t1}
+    list [catch {
+	toplevel .t1 -width 250 -height 100 -visual d
+	wm geometry .t1 +0+0
+    } msg] $msg
+} {1 {unknown or ambiguous visual name "d": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}}
+test visual-3.4 {Tk_GetVisual, parsing visual string} {
+    catch {destroy .t1}
+    list [catch {
+	toplevel .t1 -width 250 -height 100 -visual static
+	wm geometry .t1 +0+0
+    } msg] $msg
+} {1 {unknown or ambiguous visual name "static": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}}
+test visual-3.5 {Tk_GetVisual, parsing visual string} {
+    catch {destroy .t1}
+    list [catch {
+	toplevel .t1 -width 250 -height 100 -visual "pseudocolor 48x"
+	wm geometry .t1 +0+0
+    } msg] $msg
+} {1 {expected integer but got "48x"}}
+
+if {$other != ""} {
+    catch {destroy .t1}
+    catch {destroy .t2}
+    catch {destroy .t3}
+    toplevel .t1 -width 250 -height 100 -visual $other
+    wm geom .t1 +0+0
+    toplevel .t2 -width 200 -height 80 -visual [winfo visual .]
+    wm geom .t2 +5+5
+    toplevel .t3 -width 150 -height 250 -visual [winfo visual .t1]
+    wm geom .t3 +10+10
+    test visual-4.1 {Tk_GetVisual, numerical visual id} nonPortable {
+	list [winfo visualid .t2] [winfo visualid .t3]
+    } [list [winfo visualid .] [winfo visualid .t1]]
+    destroy .t1 .t2 .t3
+}
+test visual-4.2 {Tk_GetVisual, numerical visual id} {
+    catch {destroy .t1}
+    list [catch {toplevel .t1 -visual 12xyz} msg] $msg
+} {1 {bad X identifier for visual: 12xyz"}}
+test visual-4.3 {Tk_GetVisual, numerical visual id} {
+    catch {destroy .t1}
+    list [catch {toplevel .t1 -visual 1291673} msg] $msg
+} {1 {couldn't find an appropriate visual}}
+
+if ![string match *pseudocolor* $avail] {
+    test visual-5.1 {Tk_GetVisual, no matching visual} {
+	catch {destroy .t1}
+	list [catch {
+	    toplevel .t1 -width 250 -height 100 -visual "pseudocolor 8"
+	    wm geometry .t1 +0+0
+	} msg] $msg
+    } {1 {couldn't find an appropriate visual}}
+}
+
+if {[string match *pseudocolor* $avail] && ([llength $avail] > 1)} {
+    test visual-6.1 {Tk_GetVisual, no matching visual} {nonPortable} {
+	catch {destroy .t1}
+	toplevel .t1 -width 250 -height 100 -visual "best"
+	wm geometry .t1 +0+0
+	update
+	winfo visual .t1
+    } {pseudocolor}
+}
+
+# These tests are non-portable due to variations in how many colors
+# are already in use on the screen.
+
+if {([winfo visual .] == "pseudocolor") && ([winfo depth .] == 8)} {
+    eatColors .t1
+    test visual-7.1 {Tk_GetColormap, "new"} {nonPortable} {
+	toplevel .t2 -width 30 -height 20
+	wm geom .t2 +0+0
+	update
+	colorsFree .t2
+    } {0}
+    test visual-7.2 {Tk_GetColormap, "new"} {nonPortable} {
+	catch {destroy .t2}
+	toplevel .t2 -width 30 -height 20 -colormap new
+	wm geom .t2 +0+0
+	update
+	colorsFree .t2
+    } {1}
+    test visual-7.3 {Tk_GetColormap, copy from other window} {nonPortable} {
+	catch {destroy .t2}
+	toplevel .t3 -width 400 -height 50 -colormap new
+	wm geom .t3 +0+0
+	catch {destroy .t2}
+	toplevel .t2 -width 30 -height 20 -colormap .t3
+	wm geom .t2 +0+0
+	update
+	destroy .t3
+	colorsFree .t2
+    } {1}
+    test visual-7.4 {Tk_GetColormap, copy from other window} {nonPortable} {
+	catch {destroy .t2}
+	toplevel .t3 -width 400 -height 50 -colormap new
+	wm geom .t3 +0+0
+	catch {destroy .t2}
+	toplevel .t2 -width 30 -height 20 -colormap .
+	wm geom .t2 +0+0
+	update
+	destroy .t3
+	colorsFree .t2
+    } {0}
+    test visual-7.5 {Tk_GetColormap, copy from other window} {nonPortable} {
+	catch {destroy .t1}
+	list [catch {toplevel .t1 -width 400 -height 50 \
+		-colormap .choke.lots} msg] $msg
+    } {1 {bad window path name ".choke.lots"}}
+    if {$other != {}} {
+	test visual-7.6 {Tk_GetColormap, copy from other window} {nonPortable} {
+	    catch {destroy .t1}
+	    catch {destroy .t2}
+	    toplevel .t1 -width 300 -height 150 -visual $other
+	    wm geometry .t1 +0+0
+	    list [catch {toplevel .t2 -width 400 -height 50 \
+		    -colormap .t1} msg] $msg
+	} {1 {can't use colormap for .t1: incompatible visuals}}
+    }
+    catch {destroy .t1}
+    catch {destroy .t2}
+}
+
+test visual-8.1 {Tk_FreeColormap procedure} {
+    foreach w [winfo child .] {
+	destroy $w
+    }
+    toplevel .t1 -width 300 -height 180 -colormap new
+    wm geometry .t1 +0+0
+    foreach i {.t2 .t3 .t4} {
+	toplevel $i -width 250 -height 150 -colormap .t1
+	wm geometry $i +0+0
+    }
+    destroy .t1
+    destroy .t3
+    destroy .t4
+    update
+} {}
+if {$other != {}} {
+    test visual-8.2 {Tk_FreeColormap procedure} {
+	foreach w [winfo child .] {
+	    destroy $w
+	}
+	toplevel .t1 -width 300 -height 180 -visual $other
+	wm geometry .t1 +0+0
+	foreach i {.t2 .t3 .t4} {
+	    toplevel $i -width 250 -height 150 -visual $other
+	    wm geometry $i +0+0
+	}
+	destroy .t2
+	destroy .t3
+	destroy .t4
+	update
+    } {}
+}
+
+foreach w [winfo child .] {
+    destroy $w
+}
+rename eatColors {}
+rename colorsFree {}