diff options
Diffstat (limited to 'tests/visual.test')
| -rw-r--r-- | tests/visual.test | 312 |
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 {} |