tk/tests/window.test

   1 # This file is a Tcl script to test the procedures in the file
   2 # tkWindow.c.  It is organized in the standard fashion for Tcl tests.
   3 #
   4 # Copyright (c) 1995 Sun Microsystems, Inc.
   5 # Copyright (c) 1998-1999 by Scriptics Corporation.
   6 # All rights reserved.
   7 #
   8 # RCS: @(#) $Id$
   9
  10 package require tcltest 2.1
  11 namespace import -force tcltest::configure
  12 namespace import -force tcltest::testsDirectory
  13 configure -testdir [file join [pwd] [file dirname [info script]]]
  14 configure -loadfile [file join [testsDirectory] constraints.tcl]
  15 tcltest::loadTestedCommands
  16
  17 update
  18
  19 # XXX This file is woefully incomplete.  Right now it only tests
  20 # a few parts of a few procedures in tkWindow.c
  21
  22 test window-1.1 {Tk_CreateWindowFromPath procedure, parent dead} {
  23     proc bgerror msg {
  24         global x errorInfo
  25         set x [list $msg $errorInfo]
  26     }
  27     set x unchanged
  28     catch {destroy .t}
  29     frame .t -width 100 -height 50
  30     place .t -x 10 -y 10
  31     bind .t <Destroy> {button .t.b -text hello; pack .t.b}
  32     update
  33     destroy .t
  34     update
  35     rename bgerror {}
  36     set x
  37 } {{can't create window: parent has been destroyed} {can't create window: parent has been destroyed
  38     while executing
  39 "button .t.b -text hello"
  40     (command bound to event)}}
  41
  42 # Most of the tests below don't produce meaningful results;  they
  43 # will simply dump core if there are bugs.
  44
  45 test window-2.1 {Tk_DestroyWindow procedure, destroy handler deletes parent} {
  46     toplevel .t -width 300 -height 200
  47     wm geometry .t +0+0
  48     frame .t.f  -width 200 -height 200 -relief raised -bd 2
  49     place .t.f -x 0 -y 0
  50     frame .t.f.f -width 100 -height 100 -relief raised -bd 2
  51     place .t.f.f -relx 1 -rely 1 -anchor se
  52     bind .t.f <Destroy> {destroy .t}
  53     update
  54     destroy .t.f
  55 } {}
  56 test window-2.2 {Tk_DestroyWindow procedure, destroy handler deletes parent} {
  57     toplevel .t -width 300 -height 200
  58     wm geometry .t +0+0
  59     frame .t.f  -width 200 -height 200 -relief raised -bd 2
  60     place .t.f -x 0 -y 0
  61     frame .t.f.f -width 100 -height 100 -relief raised -bd 2
  62     place .t.f.f -relx 1 -rely 1 -anchor se
  63     bind .t.f.f <Destroy> {destroy .t}
  64     update
  65     destroy .t.f
  66 } {}
  67 test window-2.3 {Tk_DestroyWindow procedure, destroy handler deletes parent} {
  68     frame .f -width 80 -height 120 -relief raised -bd 2
  69     place .f -relx 0.5 -rely 0.5 -anchor center
  70     toplevel .f.t -width 300 -height 200
  71     wm geometry .f.t +0+0
  72     frame .f.t.f  -width 200 -height 200 -relief raised -bd 2
  73     place .f.t.f -x 0 -y 0
  74     frame .f.t.f.f -width 100 -height 100 -relief raised -bd 2
  75     place .f.t.f.f -relx 1 -rely 1 -anchor se
  76     update
  77     destroy .f
  78 } {}
  79
  80 # Some tests require the testmenubar command
  81 testConstraint testmenubar [llength [info commands testmenubar]]
  82
  83 test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \
  84         {unixOnly testmenubar} {
  85     catch {destroy .t}
  86     toplevel .t -width 300 -height 200
  87     wm geometry .t +0+0
  88     pack [entry .t.e]
  89     frame .t.f -bd 2 -relief raised
  90     testmenubar window .t .t.f
  91     update
  92     # If stacking order isn't handle properly, generates an X error.
  93 } {}
  94 test window-3.2 {Tk_MakeWindowExist procedure, stacking order and menubars} \
  95         {unixOnly testmenubar} {
  96     catch {destroy .t}
  97     toplevel .t -width 300 -height 200
  98     wm geometry .t +0+0
  99     pack [entry .t.e]
 100     pack [entry .t.e2]
 101     update
 102     frame .t.f -bd 2 -relief raised
 103     raise .t.f .t.e
 104     testmenubar window .t .t.f
 105     update
 106     # If stacking order isn't handled properly, generates an X error.
 107 } {}
 108
 109 test window-4.1 {Tk_NameToWindow procedure} {testmenubar} {
 110     catch {destroy .t}
 111     list [catch {winfo geometry .t} msg] $msg
 112 } {1 {bad window path name ".t"}}
 113 test window-4.2 {Tk_NameToWindow procedure} {testmenubar} {
 114     catch {destroy .t}
 115     frame .t -width 100 -height 50
 116     place .t -x 10 -y 10
 117     update
 118     list [catch {winfo geometry .t} msg] $msg
 119 } {0 100x50+10+10}
 120
 121 test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \
 122         {unixOnly testmenubar} {
 123     catch {destroy .t}
 124     toplevel .t -width 300 -height 200
 125     wm geometry .t +0+0
 126     pack [entry .t.e]
 127     pack [entry .t.e2]
 128     frame .t.f -bd 2 -relief raised
 129     testmenubar window .t .t.f
 130     update
 131     lower .t.e2 .t.f
 132     update
 133     # If stacking order isn't handled properly, generates an X error.
 134 } {}
 135
 136 # cleanup
 137 ::tcltest::cleanupTests
 138 return
 139
 140
 141
 142
 143
 144
 145
 146
 147
 148
 149
 150