Subversion Repositories or1k

# This file is a Tcl script to test the procedures in the file

# tkWindow.c.  It is organized in the standard fashion for Tcl tests.

#

# Copyright (c) 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: window.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

# XXX This file is woefully incomplete.  Right now it only tests

# a few parts of a few procedures in tkWindow.c

test window-1.1 {Tk_CreateWindowFromPath procedure, parent dead} {

    proc bgerror msg {

        global x errorInfo

        set x [list $msg $errorInfo]

    }

    set x unchanged

    catch {destroy .t}

    frame .t -width 100 -height 50

    place .t -x 10 -y 10

    bind .t  {button .t.b -text hello; pack .t.b}

    update

    destroy .t

    update

    rename bgerror {}

    set x

} {{can't create window: parent has been destroyed} {can't create window: parent has been destroyed

    while executing

"button .t.b -text hello"

    (command bound to event)}}

# Most of the tests below don't produce meaningful results;  they

# will simply dump core if there are bugs.

test window-2.1 {Tk_DestroyWindow procedure, destroy handler deletes parent} {

    toplevel .t -width 300 -height 200

    wm geometry .t +0+0

    frame .t.f  -width 200 -height 200 -relief raised -bd 2

    place .t.f -x 0 -y 0

    frame .t.f.f -width 100 -height 100 -relief raised -bd 2

    place .t.f.f -relx 1 -rely 1 -anchor se

    bind .t.f  {destroy .t}

    update

    destroy .t.f

} {}

test window-2.2 {Tk_DestroyWindow procedure, destroy handler deletes parent} {

    toplevel .t -width 300 -height 200

    wm geometry .t +0+0

    frame .t.f  -width 200 -height 200 -relief raised -bd 2

    place .t.f -x 0 -y 0

    frame .t.f.f -width 100 -height 100 -relief raised -bd 2

    place .t.f.f -relx 1 -rely 1 -anchor se

    bind .t.f.f  {destroy .t}

    update

    destroy .t.f

} {}

test window-2.3 {Tk_DestroyWindow procedure, destroy handler deletes parent} {

    frame .f -width 80 -height 120 -relief raised -bd 2

    place .f -relx 0.5 -rely 0.5 -anchor center

    toplevel .f.t -width 300 -height 200

    wm geometry .f.t +0+0

    frame .f.t.f  -width 200 -height 200 -relief raised -bd 2

    place .f.t.f -x 0 -y 0

    frame .f.t.f.f -width 100 -height 100 -relief raised -bd 2

    place .f.t.f.f -relx 1 -rely 1 -anchor se

    update

    destroy .f

} {}

if {[string compare testmenubar [info commands testmenubar]] != 0} {

    puts "This application hasn't been compiled with the testmenubar command,"

    puts "therefore I am skipping all of these tests."

    return

}

test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} unixOnly {

    catch {destroy .t}

    toplevel .t -width 300 -height 200

    wm geometry .t +0+0

    pack [entry .t.e]

    frame .t.f -bd 2 -relief raised

    testmenubar window .t .t.f

    update

    # If stacking order isn't handle properly, generates an X error.

} {}

test window-3.2 {Tk_MakeWindowExist procedure, stacking order and menubars} unixOnly {

    catch {destroy .t}

    toplevel .t -width 300 -height 200

    wm geometry .t +0+0

    pack [entry .t.e]

    pack [entry .t.e2]

    update

    frame .t.f -bd 2 -relief raised

    raise .t.f .t.e

    testmenubar window .t .t.f

    update

    # If stacking order isn't handled properly, generates an X error.

} {}

test window-4.1 {Tk_NameToWindow procedure} {

    catch {destroy .t}

    list [catch {winfo geometry .t} msg] $msg

} {1 {bad window path name ".t"}}

test window-4.2 {Tk_NameToWindow procedure} {

    catch {destroy .t}

    frame .t -width 100 -height 50

    place .t -x 10 -y 10

    update

    list [catch {winfo geometry .t} msg] $msg

} {0 100x50+10+10}

test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} unixOnly {

    catch {destroy .t}

    toplevel .t -width 300 -height 200

    wm geometry .t +0+0

    pack [entry .t.e]

    pack [entry .t.e2]

    frame .t.f -bd 2 -relief raised

    testmenubar window .t .t.f

    update

    lower .t.e2 .t.f

    update

    # If stacking order isn't handled properly, generates an X error.

} {}