diff options
Diffstat (limited to 'tests/visual.test')
| -rw-r--r-- | tests/visual.test | 562 |
1 files changed, 417 insertions, 145 deletions
diff --git a/tests/visual.test b/tests/visual.test index 1006e18..2f5c34a 100644 --- a/tests/visual.test +++ b/tests/visual.test @@ -7,8 +7,9 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands update @@ -18,7 +19,7 @@ update # use up all the slots in the colormap. # # Arguments: -# w - Name of toplevel window to create. +# w - Name of toplevel window to create. proc eatColors {w} { catch {destroy $w} @@ -27,12 +28,12 @@ proc eatColors {w} { 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 - } + 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 } @@ -43,14 +44,14 @@ proc eatColors {w} { # 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. +# 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) + && ([lindex $vals 2]/256 == $blue) } # If more than one visual type is available for the screen, pick one @@ -61,233 +62,500 @@ set avail [winfo visualsavailable .] set other {} if {[llength $avail] > 1} { foreach visual $avail { - if {$visual != $default} { - set other $visual - break - } + 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} { - list [catch {toplevel .t -visual .foo.bar} msg] $msg -} {1 {bad window path name ".foo.bar"}} -test visual-1.2 {Tk_GetVisual, copying from other window} {haveOtherVisual nonPortable} { - catch {destroy .t1} - catch {destroy .t2} +# ---------------------------------------------------------------------- + +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]" -} $other -test visual-1.3 {Tk_GetVisual, copying from other window} haveOtherVisual { - catch {destroy .t1} - catch {destroy .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]" -} $default +} -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} haveOtherVisual { - catch {destroy .t1} - catch {destroy .t2} +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 [list [catch {toplevel .t2 -gorp 80 -visual .t1} msg] $msg] + set result [toplevel .t2 -gorp 80 -visual .t1] update - set result -} {1 {unknown option "-gorp"}} -test visual-1.5 {Tk_GetVisual, default colormap} { - catch {destroy .t1} + 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]" -} $default +} -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} -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} +test visual-3.1 {Tk_GetVisual, parsing visual string} -setup { + deleteWindows +} -body { toplevel .t1 -width 250 -height 100 \ - -visual "[winfo visual .][winfo depth .]" + -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"}} +} -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} -setup { - catch {destroy .t1} - catch {destroy .t2} - catch {destroy .t3} + +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 -} -constraints {haveOtherVisual nonPortable} -body { +} -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]"} -} -result OK -cleanup { - 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}} +} -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} !havePseudocolorVisual { - 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}} +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} {havePseudocolorVisual haveMultipleVisuals nonPortable} { - catch {destroy .t1} + +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 -} {pseudocolor} +} -cleanup { + deleteWindows +} -result {pseudocolor} + # These tests are non-portable due to variations in how many colors # are already in use on the screen. - -if {[testConstraint defaultPseudocolor8]} { +test visual-7.1 {Tk_GetColormap, "new"} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { eatColors .t1 -} -test visual-7.1 {Tk_GetColormap, "new"} {defaultPseudocolor8 nonPortable} { toplevel .t2 -width 30 -height 20 wm geom .t2 +0+0 update colorsFree .t2 -} {0} -test visual-7.2 {Tk_GetColormap, "new"} {defaultPseudocolor8 nonPortable} { - catch {destroy .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 -} {1} -test visual-7.3 {Tk_GetColormap, copy from other window} {defaultPseudocolor8 nonPortable} { - catch {destroy .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 - 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} {defaultPseudocolor8 nonPortable} { - catch {destroy .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 - 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} {defaultPseudocolor8 nonPortable} { - catch {destroy .t1} - list [catch { - toplevel .t1 -width 400 -height 50 -colormap .choke.lots - } msg] $msg -} {1 {bad window path name ".choke.lots"}} -test visual-7.6 {Tk_GetColormap, copy from other window} {defaultPseudocolor8 haveOtherVisual nonPortable} { - catch {destroy .t1} - catch {destroy .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 - list [catch {toplevel .t2 -width 400 -height 50 -colormap .t1} msg] $msg -} {1 {can't use colormap for .t1: incompatible visuals}} -if {[testConstraint defaultPseudocolor8]} { - catch {destroy .t1} - catch {destroy .t2} -} + 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} { +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 + toplevel $i -width 250 -height 150 -colormap .t1 + wm geometry $i +0+0 } destroy .t1 destroy .t3 destroy .t4 update -} {} -test visual-8.2 {Tk_FreeColormap procedure} haveOtherVisual { +} -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 + 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 {} @@ -296,3 +564,7 @@ rename colorsFree {} # cleanup cleanupTests return + +# Local variables: +# mode: tcl +# End: |