Subversion Repositories or1k

# This file is a Tcl script to test out the "frame" and "toplevel"

# commands of Tk.  It is organized in the standard fashion for Tcl

# tests.

#

# Copyright (c) 1994 The Regents of the University of California.

# Copyright (c) 1994-1996 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: frame.test,v 1.1.1.1 2002-01-16 10:25:58 markom Exp $

if {[info procs test] != "test"} {

    source defs

}

foreach i [winfo children .] {

    catch {destroy $i}

}

wm geometry . {}

raise .

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

}

test frame-1.1 {frame configuration options} {

    frame .f -class NewFrame

    list [.f configure -class] [catch {.f configure -class Different} msg] $msg

} {{-class class Class Frame NewFrame} 1 {can't modify -class option after widget is created}}

catch {destroy .f}

test frame-1.2 {frame configuration options} {

    list [catch {frame .f -colormap new} msg] $msg

} {0 .f}

catch {destroy .f}

test frame-1.3 {frame configuration options} {

    list [catch {frame .f -visual default} msg] $msg

} {0 .f}

catch {destroy .f}

test frame-1.4 {frame configuration options} {

    list [catch {frame .f -screen bogus} msg] $msg

} {1 {unknown option "-screen"}}

test frame-1.5 {frame configuration options} {

    set result [list [catch {frame .f -container true} msg] $msg \

            [.f configure -container]]

    destroy .f

    set result

} {0 .f {-container container Container 0 1}}

test frame-1.6 {frame configuration options} {

    list [catch {frame .f -container bogus} msg] $msg

} {1 {expected boolean value but got "bogus"}}

test frame-1.7 {frame configuration options} {

    frame .f

    set result [list [catch {.f configure -container 1} msg] $msg]

    destroy .f

    set result

} {1 {can't modify -container option after widget is created}}

frame .f

set i 8

foreach test {

    {-background #ff0000 #ff0000 non-existent

            {unknown color name "non-existent"}}

    {-bd 4 4 badValue {bad screen distance "badValue"}}

    {-bg #00ff00 #00ff00 non-existent

            {unknown color name "non-existent"}}

    {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}

    {-cursor arrow arrow badValue {bad cursor spec "badValue"}}

    {-height 100 100 not_a_number {bad screen distance "not_a_number"}}

    {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}}

    {-highlightcolor #123456 #123456 non-existent

            {unknown color name "non-existent"}}

    {-highlightthickness 6 6 badValue {bad screen distance "badValue"}}

    {-relief ridge ridge badValue {bad relief type "badValue": must be flat, groove, raised, ridge, solid, or sunken}}

    {-takefocus "any string" "any string" {} {}}

    {-width 32 32 badValue {bad screen distance "badValue"}}

} {

    set name [lindex $test 0]

    test frame-1.$i {frame configuration options} {

        .f configure $name [lindex $test 1]

        lindex [.f configure $name] 4

    } [lindex $test 2]

    incr i

    if {[lindex $test 3] != ""} {

        test frame-1.$i {frame configuration options} {

            list [catch {.f configure $name [lindex $test 3]} msg] $msg

        } [list 1 [lindex $test 4]]

    }

    .f configure $name [lindex [.f configure $name] 3]

    incr i

}

destroy .f

set i 1

test frame-2.1 {toplevel configuration options} {

    catch {destroy .t}

    toplevel .t -width 200 -height 100 -class NewClass

    wm geometry .t +0+0

    list [.t configure -class] [catch {.t configure -class Another} msg] $msg

} {{-class class Class Toplevel NewClass} 1 {can't modify -class option after widget is created}}

test frame-2.2 {toplevel configuration options} {

    catch {destroy .t}

    toplevel .t -width 200 -height 100 -colormap new

    wm geometry .t +0+0

    list [.t configure -colormap] [catch {.t configure -colormap .} msg] $msg

} {{-colormap colormap Colormap {} new} 1 {can't modify -colormap option after widget is created}}

test frame-2.3 {toplevel configuration options} {

    catch {destroy .t}

    toplevel .t -width 200 -height 100

    wm geometry .t +0+0

    list [catch {.t configure -container 1} msg] $msg [.t configure -container]

} {1 {can't modify -container option after widget is created} {-container container Container 0 0}}

test frame-2.4 {toplevel configuration options} {

    catch {destroy .t}

    list [catch {toplevel .t -width 200 -height 100 -colormap bogus} msg] $msg

} {1 {bad window path name "bogus"}}

set default "[winfo visual .] [winfo depth .]"

test frame-2.5 {toplevel configuration options} {

    catch {destroy .t}

    toplevel .t -width 200 -height 100

    wm geometry .t +0+0

    list [catch {.t configure -use 0x44022} msg] $msg [.t configure -use]

} {1 {can't modify -use option after widget is created} {-use use Use {} {}}}

test frame-2.6 {toplevel configuration options} {

    catch {destroy .t}

    toplevel .t -width 200 -height 100 -visual default

    wm geometry .t +0+0

    list [.t configure -visual] [catch {.t configure -visual best} msg] $msg

} {{-visual visual Visual {} default} 1 {can't modify -visual option after widget is created}}

test frame-2.7 {toplevel configuration options} {

    catch {destroy .t}

    list [catch {toplevel .t -width 200 -height 100 -visual who_knows?} msg] $msg

} {1 {unknown or ambiguous visual name "who_knows?": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}}

if [info exists env(DISPLAY)] {

    test frame-2.8 {toplevel configuration options} {

        catch {destroy .t}

        toplevel .t -width 200 -height 100 -screen $env(DISPLAY)

        wm geometry .t +0+0

        list [.t configure -screen] \

                [catch {.t configure -screen another} msg] $msg

    } [list [list -screen screen Screen {} $env(DISPLAY)] 1 {can't modify -screen option after widget is created}]

}

test frame-2.9 {toplevel configuration options} {

    catch {destroy .t}

    list [catch {toplevel .t -width 200 -height 100 -screen bogus} msg] $msg

} {1 {couldn't connect to display "bogus"}}

catch {destroy .t}

toplevel .t -width 300 -height 150

wm geometry .t +0+0

update

set i 8

foreach test {

    {-background #ff0000 #ff0000 non-existent

            {unknown color name "non-existent"}}

    {-bd 4 4 badValue {bad screen distance "badValue"}}

    {-bg #00ff00 #00ff00 non-existent

            {unknown color name "non-existent"}}

    {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}

    {-cursor arrow arrow badValue {bad cursor spec "badValue"}}

    {-height 100 100 not_a_number {bad screen distance "not_a_number"}}

    {-highlightcolor #123456 #123456 non-existent

            {unknown color name "non-existent"}}

    {-highlightthickness 3 3 badValue {bad screen distance "badValue"}}

    {-relief ridge ridge badValue {bad relief type "badValue": must be flat, groove, raised, ridge, solid, or sunken}}

    {-width 32 32 badValue {bad screen distance "badValue"}}

} {

    set name [lindex $test 0]

    test frame-2.$i {frame configuration options} {

        .t configure $name [lindex $test 1]

        lindex [.t configure $name] 4

    } [lindex $test 2]

    incr i

    if {[lindex $test 3] != ""} {

        test frame-2.$i {frame configuration options} {

            list [catch {.t configure $name [lindex $test 3]} msg] $msg

        } [list 1 [lindex $test 4]]

    }

    .t configure $name [lindex [.t configure $name] 3]

    incr i

}

test frame-3.1 {TkCreateFrame procedure} {

    list [catch frame msg] $msg

} {1 {wrong # args: should be "frame pathName ?options?"}}

test frame-3.2 {TkCreateFrame procedure} {

    catch {destroy .f}

    frame .f

    set result [.f configure -class]

    destroy .f

    set result

} {-class class Class Frame Frame}

test frame-3.3 {TkCreateFrame procedure} {

    catch {destroy .t}

    toplevel .t

    wm geometry .t +0+0

    set result [.t configure -class]

    destroy .t

    set result

} {-class class Class Toplevel Toplevel}

test frame-3.4 {TkCreateFrame procedure} {

    catch {destroy .t}

    toplevel .t -width 350 -class NewClass -bg black -visual default -height 90

    wm geometry .t +0+0

    update

    list [lindex [.t configure -width] 4] \

            [lindex [.t configure -background] 4] \

            [lindex [.t configure -height] 4]

} {350 black 90}

# Be sure that the -class, -colormap, and -visual options are processed

# before configuring the widget.

test frame-3.5 {TkCreateFrame procedure} {

    catch {destroy .f}

    option add *NewFrame.background #123456

    frame .f -class NewFrame

    option clear

    lindex [.f configure -background] 4

} {#123456}

test frame-3.6 {TkCreateFrame procedure} {

    catch {destroy .f}

    option add *NewFrame.background #123456

    frame .f -class NewFrame

    option clear

    lindex [.f configure -background] 4

} {#123456}

test frame-3.7 {TkCreateFrame procedure} {

    catch {destroy .f}

    option add *NewFrame.background #332211

    option add *f.class NewFrame

    frame .f

    option clear

    list [lindex [.f configure -class] 4] [lindex [.f configure -background] 4]

} {NewFrame #332211}

test frame-3.8 {TkCreateFrame procedure} {

    catch {destroy .f}

    option add *Silly.background #122334

    option add *f.Class Silly

    frame .f

    option clear

    list [lindex [.f configure -class] 4] [lindex [.f configure -background] 4]

} {Silly #122334}

test frame-3.9 {TkCreateFrame procedure, -use option} unixOnly {

    catch {destroy .t}

    catch {destroy .x}

    toplevel .t -container 1 -width 300 -height 120

    wm geometry .t +0+0

    toplevel .x -width 140 -height 300 -use [winfo id .t] -bg green

    tkwait visibility .x

    set result "[expr [winfo rootx .x] - [winfo rootx .t]] [expr [winfo rooty .x] - [winfo rooty .t]] [winfo width .t] [winfo height .t]"

    destroy .t

    set result

} {0 0 140 300}

test frame-3.10 {TkCreateFrame procedure, -use option} unixOnly {

    catch {destroy .t}

    catch {destroy .x}

    toplevel .t -container 1 -width 300 -height 120

    wm geometry .t +0+0

    option add *x.use [winfo id .t]

    toplevel .x -width 140 -height 300 -bg green

    tkwait visibility .x

    set result "[expr [winfo rootx .x] - [winfo rootx .t]] [expr [winfo rooty .x] - [winfo rooty .t]] [winfo width .t] [winfo height .t]"

     destroy .t

    option clear

    set result

} {0 0 140 300}

# The tests below require specific display characteristics.  Even so,

# they are non-portable:  some machines don't seem to ever run out of

# colors.

if {([winfo visual .] == "pseudocolor") && ([winfo depth .] == 8)} {

    eatColors .t1

    test frame-3.11 {TkCreateFrame procedure} {nonPortable} {

        catch {destroy .t}

        toplevel .t -width 300 -height 200 -bg #475601

        wm geometry .t +0+0

        update

        colorsFree .t

    } {0}

    test frame-3.12 {TkCreateFrame procedure} {nonPortable} {

        catch {destroy .t}

        toplevel .t -width 300 -height 200 -bg #475601 -colormap new

        wm geometry .t +0+0

        update

        colorsFree .t

    } {1}

    test frame-3.13 {TkCreateFrame procedure} {nonPortable} {

        catch {destroy .t}

        option add *t.class Toplevel2

        option add *Toplevel2.colormap new

        toplevel .t -width 300 -height 200 -bg #475601

        wm geometry .t +0+0

        update

        option clear

        colorsFree .t

    } {1}

    test frame-3.14 {TkCreateFrame procedure} {nonPortable} {

        catch {destroy .t}

        option add *t.class Toplevel3

        option add *Toplevel3.Colormap new

        toplevel .t -width 300 -height 200 -bg #475601 -colormap new

        wm geometry .t +0+0

        update

        option clear

        colorsFree .t

    } {1}

    test frame-3.15 {TkCreateFrame procedure, -use and -colormap} {unixOnly nonPortable} {

        catch {destroy .t}

        catch {destroy .x}

        toplevel .t -container 1 -width 300 -height 120

        wm geometry .t +0+0

        toplevel .x -width 140 -height 300 -use [winfo id .t] -bg green -colormap new

        tkwait visibility .x

        set result "[colorsFree .t] [colorsFree .x]"

        destroy .t

        set result

    } {0 1}

    test frame-3.16 {TkCreateFrame procedure} {nonPortable} {

        catch {destroy .t}

        toplevel .t -width 300 -height 200 -bg #475601 -visual default

        wm geometry .t +0+0

        update

        colorsFree .t

    } {0}

    test frame-3.17 {TkCreateFrame procedure} {nonPortable} {

        catch {destroy .t}

        toplevel .t -width 300 -height 200 -bg #475601 -visual default \

                -colormap new

        wm geometry .t +0+0

        update

        colorsFree .t

    } {1}

    if {[lsearch -exact [winfo visualsavailable .] {grayscale 8}] >= 0} {

        test frame-3.18 {TkCreateFrame procedure} {nonPortable} {

            catch {destroy .t}

            toplevel .t -visual {grayscale 8} -width 300 -height 200 \

                    -bg #434343

            wm geometry .t +0+0

            update

            colorsFree .t 131 131 131

        } {1}

        test frame-3.19 {TkCreateFrame procedure} {nonPortable} {

            catch {destroy .t}

            option add *t.class T4

            option add *T4.visual {grayscale 8}

            toplevel .t -width 300 -height 200 -bg #434343

            wm geometry .t +0+0

            update

            option clear

            list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4]

        } {1 {grayscale 8}}

        test frame-3.20 {TkCreateFrame procedure} {nonPortable} {

            catch {destroy .t}

            set x ok

            option add *t.class T5

            option add *T5.Visual {grayscale 8}

            toplevel .t -width 300 -height 200 -bg #434343

            wm geometry .t +0+0

            update

            option clear

            list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4]

        } {1 {grayscale 8}}

        test frame-3.21 {TkCreateFrame procedure} {nonPortable} {

            catch {destroy .t}

            set x ok

            toplevel .t -visual {grayscale 8} -width 300 -height 200 \

                    -bg #434343

            wm geometry .t +0+0

            update

            colorsFree .t 131 131 131

        } {1}

    }

    destroy .t1

}

test frame-3.22 {TkCreateFrame procedure, default dimensions} {

    catch {destroy .t}

    toplevel .t

    wm geometry .t +0+0

    update

    set result "[winfo reqwidth .t] [winfo reqheight .t]"

    frame .t.f -bg red

    pack .t.f

    update

    lappend result [winfo reqwidth .t.f] [winfo reqheight .t.f]

    destroy .t

    set result

} {200 200 1 1}

test frame-3.23 {TkCreateFrame procedure} {

    catch {destroy .f}

    list [catch {frame .f -gorp glob} msg] $msg

} {1 {unknown option "-gorp"}}

test frame-3.24 {TkCreateFrame procedure} {

    catch {destroy .t}

    list [catch {

        toplevel .t -width 300 -height 200 -colormap new -bogus option

        wm geometry .t +0+0

    } msg] $msg

} {1 {unknown option "-bogus"}}

test frame-4.1 {TkCreateFrame procedure} {

    catch {destroy .f}

    catch {frame .f -gorp glob}

    winfo exists .f

} 0

test frame-4.2 {TkCreateFrame procedure} {

    catch {destroy .f}

    list [frame .f -width 200 -height 100] [winfo exists .f]

} {.f 1}

catch {destroy .f}

frame .f -highlightcolor black

test frame-5.1 {FrameWidgetCommand procedure} {

    list [catch .f msg] $msg

} {1 {wrong # args: should be ".f option ?arg arg ...?"}}

test scale-5.2 {FrameWidgetCommand procedure, cget option} {

    list [catch {.f cget} msg] $msg

} {1 {wrong # args: should be ".f cget option"}}

test scale-5.3 {FrameWidgetCommand procedure, cget option} {

    list [catch {.f cget a b} msg] $msg

} {1 {wrong # args: should be ".f cget option"}}

test scale-5.4 {FrameWidgetCommand procedure, cget option} {

    list [catch {.f cget -gorp} msg] $msg

} {1 {unknown option "-gorp"}}

test scale-5.5 {FrameWidgetCommand procedure, cget option} {

    .f cget -highlightcolor

} {black}

test scale-5.6 {FrameWidgetCommand procedure, cget option} {

    list [catch {.f cget -screen} msg] $msg

} {1 {unknown option "-screen"}}

test scale-5.7 {FrameWidgetCommand procedure, cget option} {

    catch {destroy .t}

    toplevel .t

    catch {.t cget -screen}

} {0}

catch {destroy .t}

test frame-5.8 {FrameWidgetCommand procedure, configure option} {

    llength [.f configure]

} {16}

test frame-5.9 {FrameWidgetCommand procedure, configure option} {

    list [catch {.f configure -gorp} msg] $msg

} {1 {unknown option "-gorp"}}

test frame-5.10 {FrameWidgetCommand procedure, configure option} {

    list [catch {.f configure -gorp bogus} msg] $msg

} {1 {unknown option "-gorp"}}

test frame-5.11 {FrameWidgetCommand procedure, configure option} {

    list [catch {.f configure -width 200 -height} msg] $msg

} {1 {value for "-height" missing}}

test frame-5.12 {FrameWidgetCommand procedure} {

    list [catch {.f swizzle} msg] $msg

} {1 {bad option "swizzle": must be cget or configure}}

test frame-6.1 {ConfigureFrame procedure} {

    catch {destroy .f}

    frame .f -width 150

    list [winfo reqwidth .f] [winfo reqheight .f]

} {150 1}

test frame-6.2 {ConfigureFrame procedure} {

    catch {destroy .f}

    frame .f -height 97

    list [winfo reqwidth .f] [winfo reqheight .f]

} {1 97}

test frame-6.3 {ConfigureFrame procedure} {

    catch {destroy .f}

    frame .f

    set result {}

    lappend result [winfo reqwidth .f] [winfo reqheight .f]

    .f configure -width 100 -height 180

    lappend result [winfo reqwidth .f] [winfo reqheight .f]

    .f configure -width 0 -height 0

    lappend result [winfo reqwidth .f] [winfo reqheight .f]

} {1 1 100 180 100 180}

test frame-7.1 {FrameEventProc procedure} {

    frame .frame2

    set result [info commands .frame2]

    destroy .frame2

    lappend result [info commands .frame2]

} {.frame2 {}}

test frame-7.2 {FrameEventProc procedure} {

    eval destroy [winfo children .]

    frame .f1 -bg #543210

    rename .f1 .f2

    set x {}

    lappend x [winfo children .]

    lappend x [.f2 cget -bg]

    destroy .f1

    lappend x [info command .f*] [winfo children .]

} {.f1 #543210 {} {}}

test frame-8.1 {FrameCmdDeletedProc procedure} {

    eval destroy [winfo children .]

    frame .f1

    rename .f1 {}

    list [info command .f*] [winfo children .]

} {{} {}}

test frame-8.2 {FrameCmdDeletedProc procedure} {

    eval destroy [winfo children .]

    toplevel .f1 -menu .m

    wm geometry .f1 +0+0

    update

    rename .f1 {}

    update

    list [info command .f*] [winfo children .]

} {{} {}}

test frame-8.3 {FrameCmdDeletedProc procedure} {

    eval destroy [winfo children .]

    toplevel .f1 -menu .m

    wm geometry .f1 +0+0

    menu .m

    update

    rename .f1 {}

    update

    set result [list [info command .f*] [winfo children .]]

    eval destroy [winfo children .]

    set result

} {{} .m}

test frame-9.1 {MapFrame procedure} {

    catch {destroy .t}

    toplevel .t -width 100 -height 400

    wm geometry .t +0+0

    set result [winfo ismapped .t]

    update idletasks

    lappend result [winfo ismapped .t]

} {0 1}

test frame-9.2 {MapFrame procedure} {

    catch {destroy .t}

    toplevel .t -width 100 -height 400

    wm geometry .t +0+0

    destroy .t

    update

    winfo exists .t

} {0}

test frame-9.3 {MapFrame procedure, window deleted while mapping} {

    toplevel .t2 -width 200 -height 200

    wm geometry .t2 +0+0

    tkwait visibility .t2

    catch {destroy .t}

    toplevel .t -width 100 -height 400

    wm geometry .t +0+0

    frame .t2.f -width 50 -height 50

    bind .t2.f  {destroy .t}

    pack .t2.f -side top

    update idletasks

    winfo exists .t

} {0}

set l [interp hidden]

eval destroy [winfo children .]

test frame-10.1 {frame widget vs hidden commands} {

    catch {destroy .t}

    frame .t

    interp hide {} .t

    destroy .t

    list [winfo children .] [interp hidden]

} [list {} $l]

test frame-11.1 {TkInstallFrameMenu} {

    catch {destroy .t}

    menu .m1

    .m1 add cascade -menu .m1.system

    menu .m1.system -tearoff 0

    .m1.system add command -label foo

    list [toplevel .t -menu .m1] [destroy .m1] [destroy .t]

} {.t {} {}}

test frame-11.2 {TkInstallFrameMenu - frame renamed} {

    catch {destroy .t}

    catch {rename foo {}}

    menu .m1

    .m1 add cascade -menu .m1.system

    menu .m1.system -tearoff 0

    .m1.system add command -label foo

    toplevel .t

    list [rename .t foo] [destroy .t] [destroy foo] [destroy .m1]

} {{} {} {} {}}

catch {destroy .f}

rename eatColors {}

rename colorsFree {}