571 lines
16 KiB
Plaintext
571 lines
16 KiB
Plaintext
# 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.
|
|
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
|
# All rights reserved.
|
|
|
|
package require tcltest 2.2
|
|
namespace import ::tcltest::*
|
|
tcltest::configure {*}$argv
|
|
tcltest::loadTestedCommands
|
|
|
|
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
|
|
}
|
|
}
|
|
}
|
|
testConstraint haveOtherVisual [expr {$other ne ""}]
|
|
testConstraint havePseudocolorVisual [string match *pseudocolor* $avail]
|
|
testConstraint haveMultipleVisuals [expr {[llength $avail] > 1}]
|
|
|
|
# ----------------------------------------------------------------------
|
|
|
|
test visual-1.1 {Tk_GetVisual, copying from other window} -body {
|
|
toplevel .t -visual .foo.bar
|
|
} -returnCodes error -result {bad window path name ".foo.bar"}
|
|
test visual-1.2 {Tk_GetVisual, copying from other window} -constraints {
|
|
haveOtherVisual nonPortable
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
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]"
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result $other
|
|
test visual-1.3 {Tk_GetVisual, copying from other window} -constraints {
|
|
haveOtherVisual
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
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]"
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result $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} -constraints {
|
|
haveOtherVisual
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 250 -height 100 -visual $other
|
|
wm geom .t1 +0+0
|
|
set result [toplevel .t2 -gorp 80 -visual .t1]
|
|
update
|
|
return $result
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -returnCodes error -result {unknown option "-gorp"}
|
|
test visual-1.5 {Tk_GetVisual, default colormap} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 250 -height 100 -visual default
|
|
wm geometry .t1 +0+0
|
|
update
|
|
concat "[winfo visual .t1] [winfo depth .t1]"
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result $default
|
|
|
|
|
|
test visual-2.1 {Tk_GetVisual, different visual types} -constraints {
|
|
nonPortable
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 250 -height 100 -visual {truecolor 24}
|
|
wm geometry .t1 +0+0
|
|
update
|
|
concat "[winfo visual .t1] [winfo depth .t1]"
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result {truecolor 24}
|
|
test visual-2.2 {Tk_GetVisual, different visual types} -constraints {
|
|
nonPortable
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 250 -height 100 -visual {truecolor 24}
|
|
wm geometry .t1 +0+0
|
|
update
|
|
concat "[winfo visual .t1] [winfo depth .t1]"
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result {truecolor 24}
|
|
test visual-2.3 {Tk_GetVisual, different visual types} -constraints {
|
|
nonPortable
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 250 -height 100 -visual {truecolor 24}
|
|
wm geometry .t1 +0+0
|
|
update
|
|
concat "[winfo visual .t1] [winfo depth .t1]"
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result {truecolor 24}
|
|
test visual-2.4 {Tk_GetVisual, different visual types} -constraints {
|
|
nonPortable
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 250 -height 100 -visual {truecolor 24}
|
|
wm geometry .t1 +0+0
|
|
update
|
|
concat "[winfo visual .t1] [winfo depth .t1]"
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result {truecolor 24}
|
|
test visual-2.5 {Tk_GetVisual, different visual types} -constraints {
|
|
nonPortable
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 250 -height 100 -visual {truecolor 24}
|
|
wm geometry .t1 +0+0
|
|
update
|
|
concat "[winfo visual .t1] [winfo depth .t1]"
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result {truecolor 24}
|
|
test visual-2.6 {Tk_GetVisual, different visual types} -constraints {
|
|
nonPortable
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 250 -height 100 -visual {truecolor 24}
|
|
wm geometry .t1 +0+0
|
|
update
|
|
concat "[winfo visual .t1] [winfo depth .t1]"
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result {truecolor 24}
|
|
test visual-2.7 {Tk_GetVisual, different visual types} -constraints {
|
|
nonPortable
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 250 -height 100 -visual {truecolor 24}
|
|
wm geometry .t1 +0+0
|
|
update
|
|
concat "[winfo visual .t1] [winfo depth .t1]"
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result {truecolor 24}
|
|
test visual-2.8 {Tk_GetVisual, different visual types} -constraints {
|
|
nonPortable
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 250 -height 100 -visual {truecolor 24}
|
|
wm geometry .t1 +0+0
|
|
update
|
|
concat "[winfo visual .t1] [winfo depth .t1]"
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result {truecolor 24}
|
|
test visual-2.9 {Tk_GetVisual, different visual types} -constraints {
|
|
nonPortable
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 250 -height 100 -visual {directcolor 24}
|
|
wm geometry .t1 +0+0
|
|
update
|
|
concat "[winfo visual .t1] [winfo depth .t1]"
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result {directcolor 24}
|
|
test visual-2.10 {Tk_GetVisual, different visual types} -constraints {
|
|
nonPortable
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 250 -height 100 -visual {directcolor 24}
|
|
wm geometry .t1 +0+0
|
|
update
|
|
concat "[winfo visual .t1] [winfo depth .t1]"
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result {directcolor 24}
|
|
test visual-2.11 {Tk_GetVisual, different visual types} -constraints {
|
|
nonPortable
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 250 -height 100 -visual {directcolor 24}
|
|
wm geometry .t1 +0+0
|
|
update
|
|
concat "[winfo visual .t1] [winfo depth .t1]"
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result {directcolor 24}
|
|
test visual-2.12 {Tk_GetVisual, different visual types} -constraints {
|
|
nonPortable
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 250 -height 100 -visual {directcolor 24}
|
|
wm geometry .t1 +0+0
|
|
update
|
|
concat "[winfo visual .t1] [winfo depth .t1]"
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result {directcolor 24}
|
|
test visual-2.13 {Tk_GetVisual, different visual types} -constraints {
|
|
nonPortable
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 250 -height 100 -visual {directcolor 24}
|
|
wm geometry .t1 +0+0
|
|
update
|
|
concat "[winfo visual .t1] [winfo depth .t1]"
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result {directcolor 24}
|
|
test visual-2.14 {Tk_GetVisual, different visual types} -constraints {
|
|
nonPortable
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 250 -height 100 -visual {directcolor 24}
|
|
wm geometry .t1 +0+0
|
|
update
|
|
concat "[winfo visual .t1] [winfo depth .t1]"
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result {directcolor 24}
|
|
test visual-2.15 {Tk_GetVisual, different visual types} -constraints {
|
|
nonPortable
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 250 -height 100 -visual {directcolor 24}
|
|
wm geometry .t1 +0+0
|
|
update
|
|
concat "[winfo visual .t1] [winfo depth .t1]"
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result {directcolor 24}
|
|
test visual-2.16 {Tk_GetVisual, different visual types} -constraints {
|
|
nonPortable
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 250 -height 100 -visual {directcolor 24}
|
|
wm geometry .t1 +0+0
|
|
update
|
|
concat "[winfo visual .t1] [winfo depth .t1]"
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result {directcolor 24}
|
|
test visual-2.17 {Tk_GetVisual, different visual types} -constraints {
|
|
nonPortable
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 250 -height 100 -visual {truecolor 32}
|
|
wm geometry .t1 +0+0
|
|
update
|
|
concat "[winfo visual .t1] [winfo depth .t1]"
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result {truecolor 32}
|
|
|
|
|
|
test visual-3.1 {Tk_GetVisual, parsing visual string} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 250 -height 100 \
|
|
-visual "[winfo visual .][winfo depth .]"
|
|
wm geometry .t1 +0+0
|
|
update
|
|
concat "[winfo visual .t1] [winfo depth .t1]"
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result $default
|
|
test visual-3.2 {Tk_GetVisual, parsing visual string} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 250 -height 100 -visual goop20
|
|
wm geometry .t1 +0+0
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -returnCodes error -result {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} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 250 -height 100 -visual d
|
|
wm geometry .t1 +0+0
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -returnCodes error -result {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} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 250 -height 100 -visual static
|
|
wm geometry .t1 +0+0
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -returnCodes error -result {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} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 250 -height 100 -visual "pseudocolor 48x"
|
|
wm geometry .t1 +0+0
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -returnCodes error -result {expected integer but got "48x"}
|
|
|
|
|
|
test visual-4.1 {Tk_GetVisual, numerical visual id} -constraints {
|
|
haveOtherVisual nonPortable
|
|
} -setup {
|
|
deleteWindows
|
|
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
|
|
} -body {
|
|
set v1 [list [winfo visualid .t2] [winfo visualid .t3]]
|
|
set v2 [list [winfo visualid .] [winfo visualid .t1]]
|
|
expr {$v1 eq $v2 ? "OK" : "[list $v1] ne [list $v2]"}
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result OK
|
|
test visual-4.2 {Tk_GetVisual, numerical visual id} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -visual 12xyz
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -returnCodes error -result {bad X identifier for visual: "12xyz"}
|
|
test visual-4.3 {Tk_GetVisual, numerical visual id} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -visual 1291673
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -returnCodes error -result {couldn't find an appropriate visual}
|
|
|
|
|
|
test visual-5.1 {Tk_GetVisual, no matching visual} -constraints {
|
|
!havePseudocolorVisual
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 250 -height 100 -visual "pseudocolor 8"
|
|
wm geometry .t1 +0+0
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -returnCodes error -result {couldn't find an appropriate visual}
|
|
|
|
|
|
test visual-6.1 {Tk_GetVisual, no matching visual} -constraints {
|
|
havePseudocolorVisual haveMultipleVisuals nonPortable
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 250 -height 100 -visual "best"
|
|
wm geometry .t1 +0+0
|
|
update
|
|
winfo visual .t1
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result {pseudocolor}
|
|
|
|
|
|
# These tests are non-portable due to variations in how many colors
|
|
# are already in use on the screen.
|
|
test visual-7.1 {Tk_GetColormap, "new"} -constraints {
|
|
defaultPseudocolor8 nonPortable
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
eatColors .t1
|
|
toplevel .t2 -width 30 -height 20
|
|
wm geom .t2 +0+0
|
|
update
|
|
colorsFree .t2
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result {0}
|
|
test visual-7.2 {Tk_GetColormap, "new"} -constraints {
|
|
defaultPseudocolor8 nonPortable
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
eatColors .t1
|
|
toplevel .t2 -width 30 -height 20 -colormap new
|
|
wm geom .t2 +0+0
|
|
update
|
|
colorsFree .t2
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result {1}
|
|
test visual-7.3 {Tk_GetColormap, copy from other window} -constraints {
|
|
defaultPseudocolor8 nonPortable
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
eatColors .t1
|
|
toplevel .t3 -width 400 -height 50 -colormap new
|
|
wm geom .t3 +0+0
|
|
toplevel .t2 -width 30 -height 20 -colormap .t3
|
|
wm geom .t2 +0+0
|
|
update
|
|
destroy .t3
|
|
colorsFree .t2
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result {1}
|
|
test visual-7.4 {Tk_GetColormap, copy from other window} -constraints {
|
|
defaultPseudocolor8 nonPortable
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
eatColors .t1
|
|
toplevel .t3 -width 400 -height 50 -colormap new
|
|
wm geom .t3 +0+0
|
|
toplevel .t2 -width 30 -height 20 -colormap .
|
|
wm geom .t2 +0+0
|
|
update
|
|
destroy .t3
|
|
colorsFree .t2
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result {0}
|
|
test visual-7.5 {Tk_GetColormap, copy from other window} -constraints {
|
|
defaultPseudocolor8 nonPortable
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 400 -height 50 -colormap .choke.lots
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -returnCodes error -result {bad window path name ".choke.lots"}
|
|
test visual-7.6 {Tk_GetColormap, copy from other window} -constraints {
|
|
defaultPseudocolor8 haveOtherVisual nonPortable
|
|
} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
toplevel .t1 -width 300 -height 150 -visual $other
|
|
wm geometry .t1 +0+0
|
|
toplevel .t2 -width 400 -height 50 -colormap .t1
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -returnCodes error -result {can't use colormap for .t1: incompatible visuals}
|
|
|
|
|
|
test visual-8.1 {Tk_FreeColormap procedure} -setup {
|
|
deleteWindows
|
|
} -body {
|
|
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
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result {}
|
|
test visual-8.2 {Tk_FreeColormap procedure} -constraints haveOtherVisual -setup {
|
|
deleteWindows
|
|
} -body {
|
|
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
|
|
} -cleanup {
|
|
deleteWindows
|
|
} -result {}
|
|
|
|
|
|
deleteWindows
|
|
rename eatColors {}
|
|
rename colorsFree {}
|
|
|
|
# cleanup
|
|
cleanupTests
|
|
return
|
|
|
|
# Local variables:
|
|
# mode: tcl
|
|
# End:
|