path: root/tests/visual.test

# 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.
#
# RCS: @(#) $Id: visual.test,v 1.9 2004/06/04 19:55:31 dgp Exp $

package require tcltest 2.1
eval 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
	}
    }
}
tcltest::testConstraint haveOtherVisual [expr {$other ne ""}]
tcltest::testConstraint havePseudocolorVisual [string match *pseudocolor* $avail]
tcltest::testConstraint haveMultipleVisuals [expr {[llength $avail] > 1}]
tcltest::testConstraint defaultPseudocolor8 [expr {
    ([winfo visual .] == "pseudocolor") && ([winfo depth .] == 8)
}]

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}
    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}
    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} haveOtherVisual {
    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"}}

test visual-4.1 {Tk_GetVisual, numerical visual id} -setup {
    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
} -constraints {haveOtherVisual nonPortable} -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}}

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-6.1 {Tk_GetVisual, no matching visual} {havePseudocolorVisual haveMultipleVisuals 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 {[tcltest::testConstraint defaultPseudocolor8]} {
    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}
    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}
    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}
    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}
    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 {[tcltest::testConstraint defaultPseudocolor8]} {
    catch {destroy .t1}
    catch {destroy .t2}
}

test visual-8.1 {Tk_FreeColormap procedure} {
    deleteWindows
    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
} {}
test visual-8.2 {Tk_FreeColormap procedure} haveOtherVisual {
    deleteWindows
    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
} {}

deleteWindows
rename eatColors {}
rename colorsFree {}

# cleanup
cleanupTests
return