Subversion Repositories or1k

# 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.

#

# RCS: @(#) $Id: visual.test,v 1.1.1.1 2002-01-16 10:26:00 markom Exp $

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