path: root/tests/window.test

# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.

package require tcltest 2.1
namespace import -force tcltest::configure
namespace import -force tcltest::testsDirectory
namespace import -force tcltest::interpreter
namespace import -force tcltest::makeFile
namespace import -force tcltest::removeFile
namespace import -force tcltest::testConstraint
configure -testdir [file join [pwd] [file dirname [info script]]]
configure -loadfile [file join [testsDirectory] constraints.tcl]
tcltest::loadTestedCommands
testConstraint unthreaded [expr {
    (![info exists tcl_platform(threaded)] || !$tcl_platform(threaded))
}]

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

test window-2.4 {Tk_DestroyWindow, cleanup half dead window at exit} \
        unixOrWin {
    set script [makeFile {
        update
        bind . <Destroy> exit
        destroy .
    } script]
    set error [catch {exec [interpreter] $script -geometry 10x10+0+0} msg]
    removeFile script
    list $error $msg
} {0 {}}

test window-2.5 {Tk_DestroyWindow, cleanup half dead windows at exit} \
        unixOrWin {
    set script [makeFile {
        toplevel .t
        update
        bind .t <Destroy> exit
        destroy .t
    } script]
    set error [catch {exec [interpreter] $script -geometry 10x10+0+0} msg]
    removeFile script
    list $error $msg
} {0 {}}

test window-2.6 {Tk_DestroyWindow, cleanup half dead windows at exit} \
        unixOrWin {
    set script [makeFile {
        toplevel .t
        update
        bind .t <Destroy> exit
        destroy .
    } script]
    set error [catch {exec [interpreter] $script -geometry 10x10+0+0} msg]
    removeFile script
    list $error $msg
} {0 {}}

test window-2.7 {Tk_DestroyWindow, cleanup half dead windows at exit} \
        unixOrWin {
    set script [makeFile {
        toplevel .t
        toplevel .t.f
        update
        bind .t.f <Destroy> exit
        destroy .
    } script]
    set error [catch {exec [interpreter] $script -geometry 10x10+0+0} msg]
    removeFile script
    list $error $msg
} {0 {}}

test window-2.8 {Tk_DestroyWindow, cleanup half dead windows at exit} \
        unixOrWin {
    set script [makeFile {
        toplevel .t1
        toplevel .t2
        toplevel .t3
        update
        bind .t3 <Destroy> {destroy .t2}
        bind .t2 <Destroy> {destroy .t1}
        bind .t1 <Destroy> {exit 0}
        destroy .t3
    } script]
    set error [catch {exec [interpreter] $script -geometry 10x10+0+0} msg]
    removeFile script
    list $error $msg
} {0 {}}

test window-2.9 {Tk_DestroyWindow, Destroy bindings evaluated after exit} \
    {unixOrWin unthreaded} {
    set script [makeFile {
        toplevel .t1
        toplevel .t2
        update
        bind .t2 <Destroy> {puts "Destroy .t2" ; exit 1}
        bind .t1 <Destroy> {puts "Destroy .t1" ; exit 0}
        destroy .t2
    } script]
    set error [catch {exec [interpreter] $script -geometry 10x10+0+0} msg]
    removeFile script
    list $error $msg
} {0 {Destroy .t2
Destroy .t1}}

test window-2.10 {Tk_DestroyWindow, Destroy binding evaluated once} unixOrWin {
    set script [makeFile {
        update
        bind . <Destroy> {
            puts "Destroy ."
            bind . <Destroy> {puts "Re-Destroy ."}
            exit 0
        }
        destroy .
    } script]
    set error [catch {exec [interpreter] $script -geometry 10x10+0+0} msg]
    removeFile script
    list $error $msg
} {0 {Destroy .}}

test window-2.11 {Tk_DestroyWindow, don't reanimate a half-dead window} \
        unixOrWin {
    set script [makeFile {
        toplevel .t1
        toplevel .t2
        update
        bind .t1 <Destroy> {
            if {[catch {entry .t2.newchild}]} {
                puts YES
            } else {
                puts NO
            }
        }
        bind .t2 <Destroy> {exit}
        destroy .t2
    } script]
    set error [catch {exec [interpreter] $script -geometry 10x10+0+0} msg]
    removeFile script
    list $error $msg
} {0 YES}

# Some tests require the testmenubar command
testConstraint testmenubar [llength [info commands testmenubar]]

test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \
	{unixOnly testmenubar} {
    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 testmenubar} {
    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} {testmenubar} {
    catch {destroy .t}
    list [catch {winfo geometry .t} msg] $msg
} {1 {bad window path name ".t"}}
test window-4.2 {Tk_NameToWindow procedure} {testmenubar} {
    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 testmenubar} {
    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.
} {}

# cleanup
::tcltest::cleanupTests
return