# 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.1.1.1 2007/07/10 15:05:18 duncan Exp $ package require tcltest 2.1 namespace import -force tcltest::configure namespace import -force tcltest::testsDirectory configure -testdir [file join [pwd] [file dirname [info script]]] configure -loadfile [file join [testsDirectory] constraints.tcl] 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 } } } 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} { 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 } {} if {$other != {}} { test visual-8.2 {Tk_FreeColormap procedure} { 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 ::tcltest::cleanupTests return