Enable to track git://github.com/monaka/binutils.git

[pf3gnuchains/pf3gnuchains3x.git] / tk / tests / window.test

diff --git a/tk/tests/window.test b/tk/tests/window.test
new file mode 100644 (file)
index 0000000..3f57861
--- /dev/null
+++ b/tk/tests/window.test
@@ -0,0 +1,150 @@
+# 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.
+#
+# RCS: @(#) $Id$
+
+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
+
+# 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
+} {}
+
+# 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
+
+
+
+
+
+
+
+
+
+
+
+