diff options
| -rw-r--r-- | ChangeLog | 10 | ||||
| -rw-r--r-- | tests/focus.test | 558 | ||||
| -rw-r--r-- | tests/focusTcl.test | 485 | ||||
| -rw-r--r-- | tests/grab.test | 220 | ||||
| -rw-r--r-- | tests/grid.test | 1506 | ||||
| -rw-r--r-- | tests/safe.test | 153 | ||||
| -rw-r--r-- | tests/tk.test | 206 | ||||
| -rw-r--r-- | tests/util.test | 68 |
8 files changed, 1864 insertions, 1342 deletions
@@ -1,3 +1,13 @@ +2008-08-17 Ania Pawelczyk <aniap@users.sourceforge.net> + + * tests/focus.test: Update to tcltest2 + * tests/focusTcl.test: + * tests/grab.test: + * tests/grid.test: + * tests/safe.test: + * tests/tk.test: + * tests/util.test: + 2008-08-15 Ania Pawelczyk <aniap@users.sourceforge.net> * tests/clrpick.test: Update to tcltest2 diff --git a/tests/focus.test b/tests/focus.test index af04870..c1715b3 100644 --- a/tests/focus.test +++ b/tests/focus.test @@ -6,28 +6,26 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: focus.test,v 1.11 2004/06/24 12:45:42 dkf Exp $ +# RCS: @(#) $Id: focus.test,v 1.12 2008/08/16 23:52:34 aniap Exp $ -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands - -button .b -text .b -relief raised -bd 2 -pack .b +namespace import -force tcltest::test proc focusSetup {} { - catch {destroy .t} + destroy .t toplevel .t wm geom .t +0+0 foreach i {b1 b2 b3 b4} { - button .t.$i -text .t.$i -relief raised -bd 2 - pack .t.$i + button .t.$i -text .t.$i -relief raised -bd 2 + pack .t.$i } tkwait visibility .t.b4 } proc focusSetupAlt {} { global env - catch {destroy .alt} + destroy .alt toplevel .alt -screen $env(TK_ALT_DISPLAY) foreach i {a b c d} { button .alt.$i -text .alt.$i -relief raised -bd 2 @@ -36,8 +34,6 @@ proc focusSetupAlt {} { tkwait visibility .alt.d } -# Make sure the window manager knows who has focus -catch {fixfocus} # The following procedure ensures that there is no input focus # in this application. It does it by arranging for another @@ -45,7 +41,6 @@ catch {fixfocus} # is needed to wait long enough for pending actions to get through # the X server and possibly also the window manager. -setupbg proc focusClear {} { global x; after 200 {set x 1} @@ -54,12 +49,17 @@ proc focusClear {} { update } -focusSetup -if {[testConstraint altDisplay]} { - focusSetupAlt -} -update +# Button used in some tests in the whole test file +button .b -text .b -relief raised -bd 2 +pack .b + +# Make sure the window manager knows who has focus +catch {fixfocus} + +# cleanupbg will be after 4.3 test +setupbg +update bind all <FocusIn> { append focusInfo "in %W %d\n" } @@ -69,36 +69,48 @@ bind all <FocusOut> { bind all <KeyPress> { append focusInfo "press %W %K" } +focusSetup +if {[testConstraint altDisplay]} { + focusSetupAlt +} -test focus-1.1 {Tk_FocusCmd procedure} unix { + +test focus-1.1 {Tk_FocusCmd procedure} -constraints unix -body { focusClear focus -} {} -test focus-1.2 {Tk_FocusCmd procedure} {unix altDisplay} { +} -result {} +test focus-1.2 {Tk_FocusCmd procedure} -constraints { + unix altDisplay +} -body { focus .alt.b focus -} {} -test focus-1.3 {Tk_FocusCmd procedure} unix { +} -result {} +test focus-1.3 {Tk_FocusCmd procedure} -constraints unix -body { focusClear focus .t.b3 focus -} {} -test focus-1.4 {Tk_FocusCmd procedure} unix { - list [catch {focus ""} msg] $msg -} {0 {}} -test focus-1.5 {Tk_FocusCmd procedure} unix { +} -result {} +test focus-1.4 {Tk_FocusCmd procedure} -constraints unix -body { + focus "" +} -returnCodes ok -result {} +test focus-1.5 {Tk_FocusCmd procedure} -constraints unix -body { focusClear focus -force .t focus .t.b3 focus -} {.t.b3} -test focus-1.6 {Tk_FocusCmd procedure} unix { - list [catch {focus .gorp} msg] $msg -} {1 {bad window path name ".gorp"}} -test focus-1.7 {Tk_FocusCmd procedure} unix { - list [catch {focus .gorp a} msg] $msg -} {1 {bad option ".gorp": must be -displayof, -force, or -lastfor}} -test focus-1.8 {Tk_FocusCmd procedure, focussing on dead window} unix { +} -result {.t.b3} +test focus-1.6 {Tk_FocusCmd procedure} -constraints unix -body { + focus .gorp +} -returnCodes error -result {bad window path name ".gorp"} +test focus-1.7 {Tk_FocusCmd procedure} -constraints unix -body { + focus .gorp a +} -returnCodes error -result {bad option ".gorp": must be -displayof, -force, or -lastfor} +test focus-1.8 {Tk_FocusCmd procedure, focussing on dead window} -constraints { + unix +} -setup { + destroy .t2 +} -body { + focusClear toplevel .t2 wm geom .t2 +10+10 frame .t2.f -width 200 -height 100 -bd 2 -relief raised @@ -115,109 +127,146 @@ test focus-1.8 {Tk_FocusCmd procedure, focussing on dead window} unix { destroy .t2.f lappend x [focus] destroy .t2 - set x -} {.t2.f2 .t2 .t2} -test focus-1.9 {Tk_FocusCmd procedure, -displayof option} unix { - list [catch {focus -displayof} msg] $msg -} {1 {wrong # args: should be "focus -displayof window"}} -test focus-1.10 {Tk_FocusCmd procedure, -displayof option} unix { - list [catch {focus -displayof a b} msg] $msg -} {1 {wrong # args: should be "focus -displayof window"}} -test focus-1.11 {Tk_FocusCmd procedure, -displayof option} unix { - list [catch {focus -displayof .lousy} msg] $msg -} {1 {bad window path name ".lousy"}} -test focus-1.12 {Tk_FocusCmd procedure, -displayof option} unix { + return $x +} -cleanup { + destroy .t2 +} -result {.t2.f2 .t2 .t2} +test focus-1.9 {Tk_FocusCmd procedure, -displayof option} -constraints { + unix +} -body { + focus -displayof +} -returnCodes error -result {wrong # args: should be "focus -displayof window"} +test focus-1.10 {Tk_FocusCmd procedure, -displayof option} -constraints { + unix +} -body { + focus -displayof a b +} -returnCodes error -result {wrong # args: should be "focus -displayof window"} +test focus-1.11 {Tk_FocusCmd procedure, -displayof option} -constraints { + unix +} -body { + focus -displayof .lousy +} -returnCodes error -result {bad window path name ".lousy"} +test focus-1.12 {Tk_FocusCmd procedure, -displayof option} -constraints { + unix +} -body { focusClear focus .t focus -displayof .t.b3 -} {} -test focus-1.13 {Tk_FocusCmd procedure, -displayof option} unix { +} -result {} +test focus-1.13 {Tk_FocusCmd procedure, -displayof option} -constraints { + unix +} -body { focusClear focus -force .t focus -displayof .t.b3 -} {.t} -test focus-1.14 {Tk_FocusCmd procedure, -displayof option} {unix altDisplay} { +} -result {.t} +test focus-1.14 {Tk_FocusCmd procedure, -displayof option} -constraints { + unix altDisplay +} -body { + focusClear focus -force .alt.c focus -displayof .alt -} {.alt.c} -test focus-1.15 {Tk_FocusCmd procedure, -force option} unix { - list [catch {focus -force} msg] $msg -} {1 {wrong # args: should be "focus -force window"}} -test focus-1.16 {Tk_FocusCmd procedure, -force option} unix { - list [catch {focus -force a b} msg] $msg -} {1 {wrong # args: should be "focus -force window"}} -test focus-1.17 {Tk_FocusCmd procedure, -force option} unix { - list [catch {focus -force foo} msg] $msg -} {1 {bad window path name "foo"}} -test focus-1.18 {Tk_FocusCmd procedure, -force option} unix { - list [catch {focus -force ""} msg] $msg -} {0 {}} -test focus-1.19 {Tk_FocusCmd procedure, -force option} unix { +} -result {.alt.c} +test focus-1.15 {Tk_FocusCmd procedure, -force option} -constraints unix -body { + focus -force +} -returnCodes error -result {wrong # args: should be "focus -force window"} +test focus-1.16 {Tk_FocusCmd procedure, -force option} -constraints unix -body { + focus -force a b +} -returnCodes error -result {wrong # args: should be "focus -force window"} +test focus-1.17 {Tk_FocusCmd procedure, -force option} -constraints unix -body { + focus -force foo +} -returnCodes error -result {bad window path name "foo"} +test focus-1.18 {Tk_FocusCmd procedure, -force option} -constraints unix -body { + focus -force "" +} -returnCodes ok -result {} +test focus-1.19 {Tk_FocusCmd procedure, -force option} -constraints unix -body { focusClear focus .t.b1 set x [list [focus]] focus -force .t.b1 lappend x [focus] -} {{} .t.b1} -test focus-1.20 {Tk_FocusCmd procedure, -lastfor option} unix { - list [catch {focus -lastfor} msg] $msg -} {1 {wrong # args: should be "focus -lastfor window"}} -test focus-1.21 {Tk_FocusCmd procedure, -lastfor option} unix { - list [catch {focus -lastfor 1 2} msg] $msg -} {1 {wrong # args: should be "focus -lastfor window"}} -test focus-1.22 {Tk_FocusCmd procedure, -lastfor option} unix { - list [catch {focus -lastfor who_knows?} msg] $msg -} {1 {bad window path name "who_knows?"}} -test focus-1.23 {Tk_FocusCmd procedure, -lastfor option} unix { +} -result {{} .t.b1} +test focus-1.20 {Tk_FocusCmd procedure, -lastfor option} -constraints { + unix +} -body { + focus -lastfor +} -returnCodes error -result {wrong # args: should be "focus -lastfor window"} +test focus-1.21 {Tk_FocusCmd procedure, -lastfor option} -constraints { + unix +} -body { + focus -lastfor 1 2 +} -returnCodes error -result {wrong # args: should be "focus -lastfor window"} +test focus-1.22 {Tk_FocusCmd procedure, -lastfor option} -constraints { + unix +} -body { + focus -lastfor who_knows? +} -returnCodes error -result {bad window path name "who_knows?"} +test focus-1.23 {Tk_FocusCmd procedure, -lastfor option} -constraints { + unix +} -body { + focusClear + focusSetup focus .b focus .t.b1 list [focus -lastfor .] [focus -lastfor .t.b3] -} {.b .t.b1} -test focus-1.24 {Tk_FocusCmd procedure, -lastfor option} unix { - destroy .t +} -result {.b .t.b1} +test focus-1.24 {Tk_FocusCmd procedure, -lastfor option} -constraints { + unix +} -body { + focusClear focusSetup update focus -lastfor .t.b2 -} {.t} -test focus-1.25 {Tk_FocusCmd procedure} unix { - list [catch {focus -unknown} msg] $msg -} {1 {bad option "-unknown": must be -displayof, -force, or -lastfor}} +} -result {.t} +test focus-1.25 {Tk_FocusCmd procedure} -constraints unix -body { + focus -unknown +} -returnCodes error -result {bad option "-unknown": must be -displayof, -force, or -lastfor} + -test focus-2.1 {TkFocusFilterEvent procedure} {unix nonPortable testwrapper} { +focusSetup +test focus-2.1 {TkFocusFilterEvent procedure} -constraints { + unix nonPortable testwrapper +} -body { + focusClear focus -force .b - destroy .t focusSetup update set focusInfo {} event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor \ -sendevent 0x54217567 - list $focusInfo -} {{}} -test focus-2.2 {TkFocusFilterEvent procedure} {unix nonPortable testwrapper} { + return $focusInfo +} -result {} +test focus-2.2 {TkFocusFilterEvent procedure} -constraints { + unix nonPortable testwrapper +} -body { + focusClear focus -force .b - destroy .t focusSetup update set focusInfo {} event gen .t <FocusIn> -detail NotifyAncestor -sendevent 0x547321ac list $focusInfo [focus] -} {{in .t NotifyAncestor +} -result {{in .t NotifyAncestor } .b} -test focus-2.3 {TkFocusFilterEvent procedure} {unix nonPortable testwrapper} { +test focus-2.3 {TkFocusFilterEvent procedure} -constraints { + unix nonPortable testwrapper +} -body { + focusClear focus -force .b - destroy .t focusSetup update set focusInfo {} event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor update list $focusInfo [focus -lastfor .t] -} {{out .b NotifyNonlinear +} -result {{out .b NotifyNonlinear out . NotifyNonlinearVirtual in .t NotifyNonlinear } .t} -test focus-2.4 {TkFocusFilterEvent procedure, FocusIn events} \ - {unix nonPortable testwrapper} { +test focus-2.4 {TkFocusFilterEvent procedure, FocusIn events} -constraints { + unix nonPortable testwrapper +} -body { + focusClear set result {} focus .t.b1 # Important to end with NotifyAncestor, which is an @@ -233,8 +282,8 @@ test focus-2.4 {TkFocusFilterEvent procedure, FocusIn events} \ update lappend result $focusInfo } - set result -} {{out . NotifyNonlinear + return $result +} -result {{out . NotifyNonlinear in .t NotifyNonlinearVirtual in .t.b1 NotifyNonlinear } {out . NotifyNonlinear @@ -247,19 +296,22 @@ in .t.b1 NotifyNonlinear in .t NotifyNonlinearVirtual in .t.b1 NotifyNonlinear }} -test focus-2.5 {TkFocusFilterEvent procedure, creating FocusInfo struct} \ - {unix nonPortable testwrapper} { +test focus-2.5 {TkFocusFilterEvent procedure, creating FocusInfo struct} -constraints { + unix nonPortable testwrapper +} -body { focusSetup focus .t.b1 update event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor list $focusInfo [focus] -} {{out . NotifyNonlinear +} -result {{out . NotifyNonlinear in .t NotifyNonlinearVirtual in .t.b1 NotifyNonlinear } .t.b1} -test focus-2.6 {TkFocusFilterEvent procedure, FocusIn events} \ - {unix testwrapper} { + +test focus-2.6 {TkFocusFilterEvent procedure, FocusIn events} -constraints { + unix testwrapper +} -body { focus .t.b1 focus . update @@ -268,117 +320,131 @@ test focus-2.6 {TkFocusFilterEvent procedure, FocusIn events} \ set x [focus] event gen . <KeyPress-x> list $x $focusInfo -} {.t.b1 {press .t.b1 x}} -test focus-2.7 {TkFocusFilterEvent procedure, FocusOut events} \ - {unix testwrapper} { +} -result {.t.b1 {press .t.b1 x}} +test focus-2.7 {TkFocusFilterEvent procedure, FocusOut events} -constraints { + unix testwrapper +} -body { set result {} foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear NotifyNonlinearVirtual NotifyPointer NotifyPointerRoot NotifyVirtual} { - focus -force .t.b1 - event gen [testwrapper .t] <FocusOut> -detail $detail - update - lappend result [focus] + focus -force .t.b1 + event gen [testwrapper .t] <FocusOut> -detail $detail + update + lappend result [focus] } - set result -} {{} .t.b1 {} {} .t.b1 .t.b1 {}} -test focus-2.8 {TkFocusFilterEvent procedure, FocusOut events} \ - {unix testwrapper} { + return $result +} -result {{} .t.b1 {} {} .t.b1 .t.b1 {}} +test focus-2.8 {TkFocusFilterEvent procedure, FocusOut events} -constraints { + unix testwrapper +} -body { focus -force .t.b1 event gen .t.b1 <FocusOut> -detail NotifyAncestor focus -} {.t.b1} -test focus-2.9 {TkFocusFilterEvent procedure, FocusOut events} \ - {unix testwrapper} { +} -result {.t.b1} +test focus-2.9 {TkFocusFilterEvent procedure, FocusOut events} -constraints { + unix testwrapper +} -body { focus .t.b1 event gen [testwrapper .] <FocusOut> -detail NotifyAncestor focus -} {} -test focus-2.10 {TkFocusFilterEvent procedure, Enter events} \ - {unix testwrapper} { +} -result {} +test focus-2.10 {TkFocusFilterEvent procedure, Enter events} -constraints { + unix testwrapper +} -body { set result {} focus .t.b1 focusClear foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear - NotifyNonlinearVirtual NotifyVirtual} { - event gen [testwrapper .t] <Enter> -detail $detail -focus 1 - update - lappend result [focus] - event gen [testwrapper .t] <Leave> -detail NotifyAncestor - update + NotifyNonlinearVirtual NotifyVirtual} { + event gen [testwrapper .t] <Enter> -detail $detail -focus 1 + update + lappend result [focus] + event gen [testwrapper .t] <Leave> -detail NotifyAncestor + update } - set result -} {.t.b1 {} .t.b1 .t.b1 .t.b1} -test focus-2.11 {TkFocusFilterEvent procedure, Enter events} \ - {unix testwrapper} { + return $result +} -result {.t.b1 {} .t.b1 .t.b1 .t.b1} +test focus-2.11 {TkFocusFilterEvent procedure, Enter events} -constraints { + unix testwrapper +} -body { focusClear set focusInfo {} event gen [testwrapper .t] <Enter> -detail NotifyAncestor update - set focusInfo -} {} -test focus-2.12 {TkFocusFilterEvent procedure, Enter events} \ - {unix testwrapper} { + return $focusInfo +} -result {} +test focus-2.12 {TkFocusFilterEvent procedure, Enter events} -constraints { + unix testwrapper +} -body { focus -force .b update set focusInfo {} event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 update - set focusInfo -} {} -test focus-2.13 {TkFocusFilterEvent procedure, Enter events} \ - {unix testwrapper} { + return $focusInfo +} -result {} +test focus-2.13 {TkFocusFilterEvent procedure, Enter events} -constraints { + unix testwrapper +} -body { focus .t.b1 focusClear event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 set focusInfo {} update - set focusInfo -} {in .t NotifyVirtual + return $focusInfo +} -result {in .t NotifyVirtual in .t.b1 NotifyAncestor } -test focus-2.14 {TkFocusFilterEvent procedure, Enter events, ignore errors when setting focus due to implicit focus} {unix testwrapper} { +test focus-2.14 {TkFocusFilterEvent procedure, Enter events, ignore errors when setting focus due to implicit focus} -constraints { + unix testwrapper +} -setup { + destroy .t2 + set focusInfo {} +} -body { focusClear - catch {destroy .t2} toplevel .t2 wm withdraw .t2 update - set focusInfo {} event gen [testwrapper .t2] <Enter> -detail NotifyAncestor -focus 1 update +} -cleanup { destroy .t2 -} {} -test focus-2.15 {TkFocusFilterEvent procedure, Leave events} \ - {unix testwrapper} { +} -result {} +test focus-2.15 {TkFocusFilterEvent procedure, Leave events} -constraints { + unix testwrapper +} -body { set result {} focus .t.b1 foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear NotifyNonlinearVirtual NotifyVirtual} { - focusClear - event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 - update - event gen [testwrapper .t] <Leave> -detail $detail - update - lappend result [focus] + focusClear + event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 + update + event gen [testwrapper .t] <Leave> -detail $detail + update + lappend result [focus] } - set result -} {{} .t.b1 {} {} {}} -test focus-2.16 {TkFocusFilterEvent procedure, Leave events} \ - {unix testwrapper} { - set result {} + return $result +} -result {{} .t.b1 {} {} {}} +test focus-2.16 {TkFocusFilterEvent procedure, Leave events} -constraints { + unix testwrapper +} -body { + focusClear focus .t.b1 event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 update set focusInfo {} event gen [testwrapper .t] <Leave> -detail NotifyAncestor update - set focusInfo -} {out .t.b1 NotifyAncestor + return $focusInfo +} -result {out .t.b1 NotifyAncestor out .t NotifyVirtual } -test focus-2.17 {TkFocusFilterEvent procedure, Leave events} \ - {unix testwrapper} { - set result {} +test focus-2.17 {TkFocusFilterEvent procedure, Leave events} -constraints { + unix testwrapper +} -body { + focusClear focus .t.b1 event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 update @@ -387,41 +453,49 @@ test focus-2.17 {TkFocusFilterEvent procedure, Leave events} \ event gen [testwrapper .] <Leave> -detail NotifyAncestor update list $focusInfo [focus] -} {{out .t.b1 NotifyAncestor +} -result {{out .t.b1 NotifyAncestor out .t NotifyVirtual } {}} -test focus-3.1 {SetFocus procedure, create record on focus} \ - {unix testwrapper} { + +test focus-3.1 {SetFocus procedure, create record on focus} -constraints { + unix testwrapper +} -body { toplevel .t2 -width 250 -height 100 wm geometry .t2 +0+0 update focus -force .t2 update focus -} {.t2} -catch {destroy .t2} +} -cleanup { + destroy .t2 +} -result {.t2} # This test produces no result, but it will generate a protocol # error if Tk forgets to make the window exist before focussing # on it. -test focus-3.2 {SetFocus procedure, making window exist} {unix testwrapper} { +test focus-3.2 {SetFocus procedure, making window exist} -constraints { + unix testwrapper +} -body { update button .b2 -text "Another button" focus .b2 update -} {} -catch {destroy .b2} -update +} -cleanup { + destroy .b2 + update +} -result {} # The following test doesn't produce a check-able result, but if # there are bugs it may generate an X protocol error. -test focus-3.3 {SetFocus procedure, delaying claim of X focus} \ - {unix testwrapper} { +test focus-3.3 {SetFocus procedure, delaying claim of X focus} -constraints { + unix testwrapper +} -body { focusSetup focus -force .t.b2 update -} {} -test focus-3.4 {SetFocus procedure, delaying claim of X focus} \ - {unix testwrapper} { +} -result {} +test focus-3.4 {SetFocus procedure, delaying claim of X focus} -constraints { + unix testwrapper +} -body { focusSetup wm withdraw .t focus -force .t.b2 @@ -432,52 +506,62 @@ test focus-3.4 {SetFocus procedure, delaying claim of X focus} \ update wm deiconify .t2 wm deiconify .t -} {} -catch {destroy .t2} -test focus-3.5 {SetFocus procedure, generating events} {unix testwrapper} { +} -cleanup { + destroy .t2 +} -result {} +test focus-3.5 {SetFocus procedure, generating events} -constraints { + unix testwrapper +} -body { focusSetup focusClear set focusInfo {} focus -force .t.b2 update - set focusInfo -} {in .t NotifyVirtual + return $focusInfo +} -result {in .t NotifyVirtual in .t.b2 NotifyAncestor } -test focus-3.6 {SetFocus procedure, generating events} {unix testwrapper} { +test focus-3.6 {SetFocus procedure, generating events} -constraints { + unix testwrapper +} -body { focusSetup focus -force .b update set focusInfo {} focus .t.b2 update - set focusInfo -} {out .b NotifyNonlinear + return $focusInfo +} -result {out .b NotifyNonlinear out . NotifyNonlinearVirtual in .t NotifyNonlinearVirtual in .t.b2 NotifyNonlinear } -test focus-3.7 {SetFocus procedure, generating events} \ - {unix nonPortable testwrapper} { +test focus-3.7 {SetFocus procedure, generating events} -constraints { +unix nonPortable testwrapper +} -body { # Non-portable because some platforms generate extra events. - focusSetup focusClear set focusInfo {} focus .t.b2 update - set focusInfo -} {} + return $focusInfo +} -result {} + -test focus-4.1 {TkFocusDeadWindow procedure} {unix testwrapper} { +test focus-4.1 {TkFocusDeadWindow procedure} -constraints { + unix testwrapper +} -body { focusSetup update focus -force .b update destroy .t focus -} {.b} -test focus-4.2 {TkFocusDeadWindow procedure} {unix testwrapper} { +} -result {.b} +test focus-4.2 {TkFocusDeadWindow procedure} -constraints { + unix testwrapper +} -body { focusSetup update focus -force .t.b2 @@ -486,12 +570,12 @@ test focus-4.2 {TkFocusDeadWindow procedure} {unix testwrapper} { destroy .t.b2 update focus -} {.b} - +} -result {.b} # Non-portable due to wm-specific redirection of input focus when # windows are deleted: - -test focus-4.3 {TkFocusDeadWindow procedure} {unix nonPortable testwrapper} { +test focus-4.3 {TkFocusDeadWindow procedure} -constraints { + unix nonPortable testwrapper +} -body { focusSetup update focus .t @@ -499,21 +583,27 @@ test focus-4.3 {TkFocusDeadWindow procedure} {unix nonPortable testwrapper} { destroy .t update focus -} {} -test focus-4.4 {TkFocusDeadWindow procedure} {unix testwrapper} { +} -result {} +test focus-4.4 {TkFocusDeadWindow procedure} -constraints { + unix testwrapper +} -body { focusSetup focus -force .t.b2 update destroy .t.b2 focus -} {.t} +} -result {.t} +cleanupbg + # I don't know how to test most of the remaining procedures of this file # explicitly; they've already been exercised by the preceding tests. -setupbg -test focus-5.1 {ChangeXFocus procedure, don't take focus unless have it} \ - {unix testwrapper secureserver} { +# Test 5.1 fails (before and after update) +test focus-5.1 {ChangeXFocus procedure, don't take focus unless have it} -constraints { + unix testwrapper secureserver +} -body { + setupbg focusSetup focus -force .t update @@ -523,19 +613,21 @@ test focus-5.1 {ChangeXFocus procedure, don't take focus unless have it} \ focus .t.b2 update lappend result [focus] -} {.t {} {}} - -catch {destroy .t} +} -cleanup { + cleanupbg +} -result {.t {} {}} +destroy .t bind all <FocusIn> {} bind all <FocusOut> {} bind all <KeyPress> {} -cleanupbg -fixfocus -test focus-6.1 {miscellaneous - embedded application in same process} \ - {unix testwrapper} { + +fixfocus +test focus-6.1 {miscellaneous - embedded application in same process} -constraints { + unix testwrapper +} -setup { eval interp delete [interp slaves] - catch {destroy .t} +} -body { toplevel .t wm geometry .t +0+0 frame .t.f1 -container 1 @@ -549,11 +641,11 @@ test focus-6.1 {miscellaneous - embedded application in same process} \ child eval "set argv {-use [winfo id .t.f1]}" load {} Tk child child eval { - entry .e1 -bg lightBlue - pack .e1 - bind all <FocusIn> {lappend x "focus in %W %d"} - bind all <FocusOut> {lappend x "focus out %W %d"} - set x {} + entry .e1 -bg lightBlue + pack .e1 + bind all <FocusIn> {lappend x "focus in %W %d"} + bind all <FocusOut> {lappend x "focus out %W %d"} + set x {} } # Claim the focus and wait long enough for it to really arrive. @@ -579,13 +671,17 @@ test focus-6.1 {miscellaneous - embedded application in same process} \ after 300 {set timer 1} vwait timer set result [list $x [child eval {set x}]] + return $result +} -cleanup { interp delete child - set result -} {{.t.f2.e1 {} {focus out .t.f2.e1 NotifyNonlinear} {focus out .t.f2 NotifyNonlinearVirtual} {focus in .t.f1 NotifyNonlinear} | {focus out .t.f1 NotifyNonlinear} {focus in .t.f2 NotifyNonlinearVirtual} {focus in .t.f2.e1 NotifyNonlinear}} {{focus in . NotifyVirtual} {focus in .e1 NotifyAncestor} | {focus out .e1 NotifyAncestor} {focus out . NotifyVirtual}}} -test focus-6.2 {miscellaneous - embedded application in different process} \ - {unix testwrapper} { - eval interp delete [interp slaves] - catch {destroy .t} + destroy .t + bind all <FocusIn> {} + bind all <FocusOut> {} +} -result {{.t.f2.e1 {} {focus out .t.f2.e1 NotifyNonlinear} {focus out .t.f2 NotifyNonlinearVirtual} {focus in .t.f1 NotifyNonlinear} | {focus out .t.f1 NotifyNonlinear} {focus in .t.f2 NotifyNonlinearVirtual} {focus in .t.f2.e1 NotifyNonlinear}} {{focus in . NotifyVirtual} {focus in .e1 NotifyAncestor} | {focus out .e1 NotifyAncestor} {focus out . NotifyVirtual}}} + +test focus-6.2 {miscellaneous - embedded application in different process} -constraints { + unix testwrapper +} -body { setupbg toplevel .t wm geometry .t +0+0 @@ -598,11 +694,11 @@ test focus-6.2 {miscellaneous - embedded application in different process} \ bind all <FocusOut> {lappend x "focus out %W %d"} setupbg -use [winfo id .t.f1] dobg { - entry .e1 -bg lightBlue - pack .e1 - bind all <FocusIn> {lappend x "focus in %W %d"} - bind all <FocusOut> {lappend x "focus out %W %d"} - set x {} + entry .e1 -bg lightBlue + pack .e1 + bind all <FocusIn> {lappend x "focus in %W %d"} + bind all <FocusOut> {lappend x "focus out %W %d"} + set x {} } # Claim the focus and wait long enough for it to really arrive. @@ -628,13 +724,17 @@ test focus-6.2 {miscellaneous - embedded application in different process} \ after 300 {set timer 1} vwait timer set result [list $x [dobg {set x}]] + return $result +} -cleanup { + destroy .t cleanupbg - set result -} {{.t.f2.e1 {} {focus out .t.f2.e1 NotifyNonlinear} {focus out .t.f2 NotifyNonlinearVirtual} {focus in .t.f1 NotifyNonlinear} | {focus out .t.f1 NotifyNonlinear} {focus in .t.f2 NotifyNonlinearVirtual} {focus in .t.f2.e1 NotifyNonlinear}} {{focus in . NotifyVirtual} {focus in .e1 NotifyAncestor} | {focus out .e1 NotifyAncestor} {focus out . NotifyVirtual}}} + bind all <FocusIn> {} + bind all <FocusOut> {} +} -result {{.t.f2.e1 {} {focus out .t.f2.e1 NotifyNonlinear} {focus out .t.f2 NotifyNonlinearVirtual} {focus in .t.f1 NotifyNonlinear} | {focus out .t.f1 NotifyNonlinear} {focus in .t.f2 NotifyNonlinearVirtual} {focus in .t.f2.e1 NotifyNonlinear}} {{focus in . NotifyVirtual} {focus in .e1 NotifyAncestor} | {focus out .e1 NotifyAncestor} {focus out . NotifyVirtual}}} + + deleteWindows -bind all <FocusIn> {} -bind all <FocusOut> {} # cleanup cleanupTests diff --git a/tests/focusTcl.test b/tests/focusTcl.test index 4a891b5..be07fff 100644 --- a/tests/focusTcl.test +++ b/tests/focusTcl.test @@ -7,133 +7,264 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: focusTcl.test,v 1.8 2004/05/23 17:34:48 dkf Exp $ +# RCS: @(#) $Id: focusTcl.test,v 1.9 2008/08/16 23:52:34 aniap Exp $ -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test + +option add *takeFocus 1 +option add *highlightThickness 2 +. configure -takefocus 1 -highlightthickness 2 proc setup1 w { if {$w == "."} { - set w "" + set w "" } foreach i {a b c d} { - frame $w.$i -width 200 -height 50 -bd 2 -relief raised - pack $w.$i + destroy $w.$i + frame $w.$i -width 200 -height 50 -bd 2 -relief raised + pack $w.$i } .b configure -width 0 -height 0 foreach i {x y z} { - button $w.b.$i -text "Button $w.b.$i" - pack $w.b.$i -side left + destroy $w.b.$i + button $w.b.$i -text "Button $w.b.$i" + pack $w.b.$i -side left } if {![winfo ismapped $w.b.z]} { - tkwait visibility $w.b.z + tkwait visibility $w.b.z } } -option add *takeFocus 1 -option add *highlightThickness 2 -. configure -takefocus 1 -highlightthickness 2 -test focusTcl-1.1 {tk_focusNext procedure, no children} { +proc cleanup1 w { + if {$w == "."} { + set w "" + } + foreach i {a b c d} { + destroy $w.$i + } + foreach i {x y z} { + destroy $w.b.$i + } +} + + +test focusTcl-1.1 {tk_focusNext procedure, no children} -body { tk_focusNext . -} {.} -setup1 . -test focusTcl-1.2 {tk_focusNext procedure, basic tree traversal} { +} -result {.} + +test focusTcl-1.2 {tk_focusNext procedure, basic tree traversal} -body { + setup1 . tk_focusNext . -} {.a} -test focusTcl-1.3 {tk_focusNext procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.a} +test focusTcl-1.3 {tk_focusNext procedure, basic tree traversal} -body { + setup1 . tk_focusNext .a -} {.b} -test focusTcl-1.4 {tk_focusNext procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.b} +test focusTcl-1.4 {tk_focusNext procedure, basic tree traversal} -body { + setup1 . tk_focusNext .b -} {.b.x} -test focusTcl-1.5 {tk_focusNext procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.b.x} +test focusTcl-1.5 {tk_focusNext procedure, basic tree traversal} -body { + setup1 . tk_focusNext .b.x -} {.b.y} -test focusTcl-1.6 {tk_focusNext procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.b.y} +test focusTcl-1.6 {tk_focusNext procedure, basic tree traversal} -body { + setup1 . tk_focusNext .b.y -} {.b.z} -test focusTcl-1.7 {tk_focusNext procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.b.z} +test focusTcl-1.7 {tk_focusNext procedure, basic tree traversal} -body { + setup1 . tk_focusNext .b.z -} {.c} -test focusTcl-1.8 {tk_focusNext procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.c} +test focusTcl-1.8 {tk_focusNext procedure, basic tree traversal} -body { + setup1 . tk_focusNext .c -} {.d} -test focusTcl-1.9 {tk_focusNext procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.d} +test focusTcl-1.9 {tk_focusNext procedure, basic tree traversal} -body { + setup1 . tk_focusNext .d -} {.} -foreach w {.b .b.x .b.y .c .d} { - $w configure -takefocus 0 -} -test focusTcl-1.10 {tk_focusNext procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.} + +test focusTcl-1.10 {tk_focusNext procedure, basic tree traversal} -body { + setup1 . + foreach w {.b .b.x .b.y .c .d} { + $w configure -takefocus 0 + } tk_focusNext .a -} {.b.z} -test focusTcl-1.11 {tk_focusNext procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.b.z} +test focusTcl-1.11 {tk_focusNext procedure, basic tree traversal} -body { + setup1 . + foreach w {.b .b.x .b.y .c .d} { + $w configure -takefocus 0 + } tk_focusNext .b.z -} {.} -test focusTcl-1.12 {tk_focusNext procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.} + +test focusTcl-1.12 {tk_focusNext procedure, basic tree traversal} -body { + setup1 . deleteWindows setup1 . update . configure -takefocus 0 tk_focusNext .d -} {.a} -. configure -takefocus 1 +} -cleanup { + . configure -takefocus 1 + cleanup1 . +} -result {.a} + + +test focusTcl-2.1 {tk_focusNext procedure, toplevels} -setup { + deleteWindows +} -body { + setup1 . + toplevel .t + wm geom .t +0+0 + toplevel .t2 + wm geom .t2 -0+0 + raise .t .a -deleteWindows -setup1 . -toplevel .t -wm geom .t +0+0 -toplevel .t2 -wm geom .t2 -0+0 -raise .t .a -test focusTcl-2.1 {tk_focusNext procedure, toplevels} { tk_focusNext .a -} {.b} -test focusTcl-2.2 {tk_focusNext procedure, toplevels} { +} -cleanup { + deleteWindows +} -result {.b} +test focusTcl-2.2 {tk_focusNext procedure, toplevels} -setup { + deleteWindows +} -body { + setup1 . + toplevel .t + wm geom .t +0+0 + toplevel .t2 + wm geom .t2 -0+0 + raise .t .a + tk_focusNext .d -} {.} -test focusTcl-2.3 {tk_focusNext procedure, toplevels} { +} -cleanup { + deleteWindows +} -result {.} +test focusTcl-2.3 {tk_focusNext procedure, toplevels} -setup { + deleteWindows +} -body { + setup1 . + toplevel .t + wm geom .t +0+0 + toplevel .t2 + wm geom .t2 -0+0 + raise .t .a + tk_focusNext .t -} {.t} -setup1 .t -raise .t.b -test focusTcl-2.4 {tk_focusNext procedure, toplevels} { +} -cleanup { + deleteWindows +} -result {.t} +test focusTcl-2.4 {tk_focusNext procedure, toplevels} -setup { + deleteWindows +} -body { + setup1 . + toplevel .t + wm geom .t +0+0 + toplevel .t2 + wm geom .t2 -0+0 + raise .t .a + setup1 .t + raise .t.b + tk_focusNext .t -} {.t.a} -test focusTcl-2.5 {tk_focusNext procedure, toplevels} { +} -cleanup { + deleteWindows +} -result {.t.a} +test focusTcl-2.5 {tk_focusNext procedure, toplevels} -setup { + deleteWindows +} -body { + setup1 . + toplevel .t + wm geom .t +0+0 + toplevel .t2 + wm geom .t2 -0+0 + raise .t .a + setup1 .t + raise .t.b + tk_focusNext .t.b.z -} {.t} +} -cleanup { + deleteWindows +} -result {.t} -deleteWindows -test focusTcl-3.1 {tk_focusPrev procedure, no children} { + +test focusTcl-3.1 {tk_focusPrev procedure, no children} -body { tk_focusPrev . -} {.} -setup1 . -test focusTcl-3.2 {tk_focusPrev procedure, basic tree traversal} { +} -result {.} + +test focusTcl-3.2 {tk_focusPrev procedure, basic tree traversal} -body { + setup1 . tk_focusPrev . -} {.d} -test focusTcl-3.3 {tk_focusPrev procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.d} +test focusTcl-3.3 {tk_focusPrev procedure, basic tree traversal} -body { + setup1 . tk_focusPrev .d -} {.c} -test focusTcl-3.4 {tk_focusPrev procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.c} +test focusTcl-3.4 {tk_focusPrev procedure, basic tree traversal} -body { + setup1 . tk_focusPrev .c -} {.b.z} -test focusTcl-3.5 {tk_focusPrev procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.b.z} +test focusTcl-3.5 {tk_focusPrev procedure, basic tree traversal} -body { + setup1 . tk_focusPrev .b.z -} {.b.y} -test focusTcl-3.6 {tk_focusPrev procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.b.y} +test focusTcl-3.6 {tk_focusPrev procedure, basic tree traversal} -body { + setup1 . tk_focusPrev .b.y -} {.b.x} -test focusTcl-3.7 {tk_focusPrev procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.b.x} +test focusTcl-3.7 {tk_focusPrev procedure, basic tree traversal} -body { + setup1 . tk_focusPrev .b.x -} {.b} -test focusTcl-3.8 {tk_focusPrev procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.b} +test focusTcl-3.8 {tk_focusPrev procedure, basic tree traversal} -body { + setup1 . tk_focusPrev .b -} {.a} -test focusTcl-3.9 {tk_focusPrev procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.a} +test focusTcl-3.9 {tk_focusPrev procedure, basic tree traversal} -body { + setup1 . tk_focusPrev .a -} {.} +} -cleanup { + cleanup1 . +} -result {.} + deleteWindows setup1 . @@ -142,35 +273,95 @@ wm geom .t +0+0 toplevel .t2 wm geom .t2 -0+0 raise .t .a -test focusTcl-4.1 {tk_focusPrev procedure, toplevels} { +test focusTcl-4.1 {tk_focusPrev procedure, toplevels} -setup { + deleteWindows +} -body { + setup1 . + toplevel .t + wm geom .t +0+0 + toplevel .t2 + wm geom .t2 -0+0 + raise .t .a + tk_focusPrev . -} {.d} -test focusTcl-4.2 {tk_focusPrev procedure, toplevels} { +} -cleanup { + deleteWindows +} -result {.d} +test focusTcl-4.2 {tk_focusPrev procedure, toplevels} -setup { + deleteWindows +} -body { + setup1 . + toplevel .t + wm geom .t +0+0 + toplevel .t2 + wm geom .t2 -0+0 + raise .t .a + tk_focusPrev .b -} {.a} -test focusTcl-4.3 {tk_focusPrev procedure, toplevels} { +} -cleanup { + deleteWindows +} -result {.a} +test focusTcl-4.3 {tk_focusPrev procedure, toplevels} -setup { + deleteWindows +} -body { + setup1 . + toplevel .t + wm geom .t +0+0 + toplevel .t2 + wm geom .t2 -0+0 + raise .t .a + tk_focusPrev .t -} {.t} -setup1 .t -update -.t configure -takefocus 0 -raise .t.b -test focusTcl-4.4 {tk_focusPrev procedure, toplevels} { +} -cleanup { + deleteWindows +} -result {.t} + +test focusTcl-4.4 {tk_focusPrev procedure, toplevels} -setup { + deleteWindows +} -body { + setup1 . + toplevel .t + wm geom .t +0+0 + toplevel .t2 + wm geom .t2 -0+0 + raise .t .a + setup1 .t + update + .t configure -takefocus 0 + raise .t.b + tk_focusPrev .t -} {.t.b.z} -test focusTcl-4.5 {tk_focusPrev procedure, toplevels} { - tk_focusPrev .t.a -} {.t.b.z} +} -cleanup { + deleteWindows +} -result {.t.b.z} +test focusTcl-4.5 {tk_focusPrev procedure, toplevels} -setup { + deleteWindows +} -body { + setup1 . + toplevel .t + wm geom .t +0+0 + toplevel .t2 + wm geom .t2 -0+0 + raise .t .a + setup1 .t + update + .t configure -takefocus 0 + raise .t.b -deleteWindows -test focusTcl-5.1 {tkFocusOK procedure, -takefocus 0} { + tk_focusPrev .t.a +} -cleanup { deleteWindows +} -result {.t.b.z} + + +test focusTcl-5.1 {tkFocusOK procedure, -takefocus 0} -body { setup1 . .b.x configure -takefocus 0 tk_focusNext .b -} {.b.y} -test focusTcl-5.2 {tkFocusOK procedure, -takefocus 1} { - deleteWindows +} -cleanup { + cleanup1 . +} -result {.b.y} +test focusTcl-5.2 {tkFocusOK procedure, -takefocus 1} -body { setup1 . pack forget .b update @@ -178,103 +369,119 @@ test focusTcl-5.2 {tkFocusOK procedure, -takefocus 1} { .b.y configure -takefocus "" .b.z configure -takefocus "" list [tk_focusNext .a] [tk_focusNext .b.x] -} {.c .c} -test focusTcl-5.3 {tkFocusOK procedure, -takefocus procedure} { +} -cleanup { + cleanup1 . +} -result {.c .c} +test focusTcl-5.3 {tkFocusOK procedure, -takefocus procedure} -body { proc t w { - if {$w == ".b.x"} { - return 1 - } elseif {$w == ".b.y"} { - return "" - } - return 0 + if {$w == ".b.x"} { + return 1 + } elseif {$w == ".b.y"} { + return "" } - deleteWindows + return 0 + } + setup1 . pack forget .b.y update .b configure -takefocus "" foreach w {.b.x .b.y .b.z .c} { - $w configure -takefocus t + $w configure -takefocus t } list [tk_focusNext .a] [tk_focusNext .b.x] -} {.b.x .d} -test focusTcl-5.4 {tkFocusOK procedure, -takefocus ""} { - deleteWindows +} -cleanup { + cleanup1 . +} -result {.b.x .d} +test focusTcl-5.4 {tkFocusOK procedure, -takefocus ""} -body { setup1 . .b.x configure -takefocus "" update tk_focusNext .b -} {.b.x} -test focusTcl-5.5 {tkFocusOK procedure, -takefocus "", not mapped} { - deleteWindows +} -cleanup { + cleanup1 . +} -result {.b.x} +test focusTcl-5.5 {tkFocusOK procedure, -takefocus "", not mapped} -body { setup1 . .b.x configure -takefocus "" pack unpack .b.x update tk_focusNext .b -} {.b.y} -test focusTcl-5.6 {tkFocusOK procedure, -takefocus "", not mapped} { - deleteWindows +} -cleanup { + cleanup1 . +} -result {.b.y} +test focusTcl-5.6 {tkFocusOK procedure, -takefocus "", not mapped} -body { setup1 . foreach w {.b.x .b.y .b.z} { - $w configure -takefocus "" + $w configure -takefocus "" } pack unpack .b update tk_focusNext .b -} {.c} -test focusTcl-5.7 {tkFocusOK procedure, -takefocus "", not mapped} { - deleteWindows +} -cleanup { + cleanup1 . +} -result {.c} +test focusTcl-5.7 {tkFocusOK procedure, -takefocus "", not mapped} -body { setup1 . .b.y configure -takefocus 1 pack unpack .b.y update tk_focusNext .b.x -} {.b.z} -test focusTcl-5.8 {tkFocusOK procedure, -takefocus "", not mapped} { +} -cleanup { + cleanup1 . +} -result {.b.z} +test focusTcl-5.8 {tkFocusOK procedure, -takefocus "", not mapped} -body { proc always args {return 1} - deleteWindows setup1 . .b.y configure -takefocus always pack unpack .b.y update tk_focusNext .b.x -} {.b.y} -test focusTcl-5.9 {tkFocusOK procedure, -takefocus "", window disabled} { - deleteWindows +} -cleanup { + cleanup1 . +} -result {.b.y} +test focusTcl-5.9 {tkFocusOK procedure, -takefocus "", window disabled} -body { setup1 . foreach w {.b.x .b.y .b.z} { - $w configure -takefocus "" + $w configure -takefocus "" } update .b.x configure -state disabled tk_focusNext .b -} {.b.y} -test focusTcl-5.10 {tkFocusOK procedure, -takefocus "", check for bindings} { - deleteWindows +} -cleanup { + cleanup1 . +} -result {.b.y} +test focusTcl-5.10 {tkFocusOK procedure, -takefocus "", check for bindings} -body { setup1 . foreach w {.a .b .c .d} { - $w configure -takefocus "" + $w configure -takefocus "" } update bind .a <Key> {foo} list [tk_focusNext .] [tk_focusNext .a] -} {.a .b.x} -test focusTcl-5.11 {tkFocusOK procedure, -takefocus "", check for bindings} { - deleteWindows +} -cleanup { + cleanup1 . +} -result {.a .b.x} +test focusTcl-5.11 {tkFocusOK procedure, -takefocus "", check for bindings} -body { setup1 . foreach w {.a .b .c .d} { - $w configure -takefocus "" + $w configure -takefocus "" } update bind Frame <Key> {foo} list [tk_focusNext .] [tk_focusNext .a] -} {.a .b} +} -cleanup { + cleanup1 . + bind Frame <Key> {} +} -result {.a .b} + -bind Frame <Key> {} . configure -takefocus 0 -highlightthickness 0 option clear # cleanup cleanupTests return + + + diff --git a/tests/grab.test b/tests/grab.test index 3baf7a5..c9f6688 100644 --- a/tests/grab.test +++ b/tests/grab.test @@ -7,142 +7,147 @@ # Copyright (c) 1998-2000 by Ajuba Solutions. # All rights reserved. # -# RCS: @(#) $Id: grab.test,v 1.4 2008/07/23 23:24:24 nijtmans Exp $ +# RCS: @(#) $Id: grab.test,v 1.5 2008/08/16 23:52:34 aniap Exp $ -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test # There's currently no way to test the actual grab effect, per se, # in an automated test. Therefore, this test suite only covers the # interface to the grab command (ie, error messages, etc.) -test grab-1.1 {Tk_GrabObjCmd} { - list [catch {grab} msg] $msg -} [list 1 "wrong # args: should be \"grab ?-global? window\" or \"grab option ?arg ...?\""] -test grab-1.2 {Tk_GrabObjCmd} { + +test grab-1.1 {Tk_GrabObjCmd} -body { + grab +} -returnCodes error -result {wrong # args: should be "grab ?-global? window" or "grab option ?arg ...?"} +test grab-1.2 {Tk_GrabObjCmd} -body { rename grab grabTest1.2 - set res [list [catch {grabTest1.2} msg] $msg] + grabTest1.2 +} -cleanup { rename grabTest1.2 grab - set res -} [list 1 "wrong # args: should be \"grabTest1.2 ?-global? window\" or \"grabTest1.2 option ?arg ...?\""] - -test grab-1.3 {Tk_GrabObjCmd, "grab ?-global? window"} { - list [catch {grab .foo bar baz} msg] $msg -} [list 1 "wrong # args: should be \"grab ?-global? window\""] -test grab-1.4 {Tk_GrabObjCmd, "grab ?-global? window"} { - catch {destroy .foo} - list [catch {grab .foo} msg] $msg -} [list 1 "bad window path name \".foo\""] -test grab-1.5 {Tk_GrabObjCmd, "grab ?-global? window"} { - list [catch {grab -foo bar} msg] $msg -} [list 1 "bad option \"-foo\": must be -global"] -test grab-1.6 {Tk_GrabObjCmd, "grab ?-global? window"} { - catch {destroy .foo} - list [catch {grab -global .foo} msg] $msg -} [list 1 "bad window path name \".foo\""] - -test grab-1.7 {Tk_GrabObjCmd} { - list [catch {grab foo} msg] $msg -} [list 1 "bad option \"foo\": must be current, release, set, or status"] - -test grab-1.8 {Tk_GrabObjCmd, "grab current ?window?"} { - list [catch {grab current foo bar} msg] $msg -} [list 1 "wrong # args: should be \"grab current ?window?\""] -test grab-1.9 {Tk_GrabObjCmd, "grab current ?window?"} { - catch {destroy .foo} - list [catch {grab current .foo} msg] $msg -} [list 1 "bad window path name \".foo\""] - -test grab-1.10 {Tk_GrabObjCmd, "grab release window"} { - list [catch {grab release} msg] $msg -} [list 1 "wrong # args: should be \"grab release window\""] -test grab-1.11 {Tk_GrabObjCmd, "grab release window"} { - catch {destroy .foo} - list [catch {grab release .foo} msg] $msg -} [list 0 ""] -test grab-1.12 {Tk_GrabObjCmd, "grab release window"} { - list [catch {grab release foo} msg] $msg -} [list 0 ""] - -test grab-1.13 {Tk_GrabObjCmd, "grab set ?-global? window"} { - list [catch {grab set} msg] $msg -} [list 1 "wrong # args: should be \"grab set ?-global? window\""] -test grab-1.14 {Tk_GrabObjCmd, "grab set ?-global? window"} { - list [catch {grab set foo bar baz} msg] $msg -} [list 1 "wrong # args: should be \"grab set ?-global? window\""] -test grab-1.15 {Tk_GrabObjCmd, "grab set ?-global? window"} { - catch {destroy .foo} - list [catch {grab set .foo} msg] $msg -} [list 1 "bad window path name \".foo\""] -test grab-1.16 {Tk_GrabObjCmd, "grab set ?-global? window"} { - list [catch {grab set -foo bar} msg] $msg -} [list 1 "bad option \"-foo\": must be -global"] -test grab-1.17 {Tk_GrabObjCmd, "grab set ?-global? window"} { - catch {destroy .foo} - list [catch {grab set -global .foo} msg] $msg -} [list 1 "bad window path name \".foo\""] - -test grab-1.18 {Tk_GrabObjCmd, "grab status window"} { - list [catch {grab status} msg] $msg -} [list 1 "wrong # args: should be \"grab status window\""] -test grab-1.19 {Tk_GrabObjCmd, "grab status window"} { - list [catch {grab status foo bar} msg] $msg -} [list 1 "wrong # args: should be \"grab status window\""] -test grab-1.20 {Tk_GrabObjCmd, "grab status window"} { - catch {destroy .foo} - list [catch {grab status .foo} msg] $msg -} [list 1 "bad window path name \".foo\""] - -test grab-2.1 {Tk_GrabObjCmd, grab status gives correct status} { +} -returnCodes error -result {wrong # args: should be "grabTest1.2 ?-global? window" or "grabTest1.2 option ?arg ...?"} + +test grab-1.3 {Tk_GrabObjCmd, "grab ?-global? window"} -body { + grab .foo bar baz +} -returnCodes error -result {wrong # args: should be "grab ?-global? window"} +test grab-1.4 {Tk_GrabObjCmd, "grab ?-global? window"} -body { + destroy .foo + grab .foo +} -returnCodes error -result {bad window path name ".foo"} +test grab-1.5 {Tk_GrabObjCmd, "grab ?-global? window"} -body { + grab -foo bar +} -returnCodes error -result {bad option "-foo": must be -global} +test grab-1.6 {Tk_GrabObjCmd, "grab ?-global? window"} -body { + destroy .foo + grab -global .foo +} -returnCodes error -result {bad window path name ".foo"} + +test grab-1.7 {Tk_GrabObjCmd} -body { + grab foo +} -returnCodes error -result {bad option "foo": must be current, release, set, or status} + +test grab-1.8 {Tk_GrabObjCmd, "grab current ?window?"} -body { + grab current foo bar +} -returnCodes error -result {wrong # args: should be "grab current ?window?"} +test grab-1.9 {Tk_GrabObjCmd, "grab current ?window?"} -body { + destroy .foo + grab current .foo +} -returnCodes error -result {bad window path name ".foo"} + +test grab-1.10 {Tk_GrabObjCmd, "grab release window"} -body { + grab release +} -returnCodes error -result {wrong # args: should be "grab release window"} +test grab-1.11 {Tk_GrabObjCmd, "grab release window"} -body { + destroy .foo + grab release .foo +} -returnCodes ok -result {} +test grab-1.12 {Tk_GrabObjCmd, "grab release window"} -body { + grab release foo +} -returnCodes ok -result {} + +test grab-1.13 {Tk_GrabObjCmd, "grab set ?-global? window"} -body { + grab set +} -returnCodes error -result {wrong # args: should be "grab set ?-global? window"} +test grab-1.14 {Tk_GrabObjCmd, "grab set ?-global? window"} -body { + grab set foo bar baz +} -returnCodes error -result {wrong # args: should be "grab set ?-global? window"} +test grab-1.15 {Tk_GrabObjCmd, "grab set ?-global? window"} -body { + destroy .foo + grab set .foo +} -returnCodes error -result {bad window path name ".foo"} +test grab-1.16 {Tk_GrabObjCmd, "grab set ?-global? window"} -body { + grab set -foo bar +} -returnCodes error -result {bad option "-foo": must be -global} +test grab-1.17 {Tk_GrabObjCmd, "grab set ?-global? window"} -body { + destroy .foo + grab set -global .foo +} -returnCodes error -result {bad window path name ".foo"} + +test grab-1.18 {Tk_GrabObjCmd, "grab status window"} -body { + grab status +} -returnCodes error -result {wrong # args: should be "grab status window"} +test grab-1.19 {Tk_GrabObjCmd, "grab status window"} -body { + grab status foo bar +} -returnCodes error -result {wrong # args: should be "grab status window"} +test grab-1.20 {Tk_GrabObjCmd, "grab status window"} -body { + destroy .foo + grab status .foo +} -returnCodes error -result {bad window path name ".foo"} + + +test grab-2.1 {Tk_GrabObjCmd, grab status gives correct status} -body { set curr [grab current .] if { [string length $curr] > 0 } { grab release $curr } - set result [grab status .] + grab status . +} -cleanup { grab release . - set result -} "none" -test grab-2.2 {Tk_GrabObjCmd, grab status gives correct status} { +} -result {none} +test grab-2.2 {Tk_GrabObjCmd, grab status gives correct status} -body { set curr [grab current .] if { [string length $curr] > 0 } { grab release $curr } grab . - set result [grab status .] + grab status . +} -cleanup { grab release . - set result -} "local" -test grab-2.3 {Tk_GrabObjCmd, grab status gives correct status} { +} -result {local} +test grab-2.3 {Tk_GrabObjCmd, grab status gives correct status} -body { set curr [grab current .] if { [string length $curr] > 0 } { grab release $curr } grab -global . - set result [grab status .] + grab status . +} -cleanup { grab release . - set result -} "global" +} -result {global} + -test grab-3.1 {Tk_GrabObjCmd, grab current gives correct information} { +test grab-3.1 {Tk_GrabObjCmd, grab current gives correct information} -body { set curr [grab current .] if { [string length $curr] > 0 } { grab release $curr } - set curr -} "" -test grab-3.2 {Tk_GrabObjCmd, grab current gives correct information} { + return $curr +} -result {} +test grab-3.2 {Tk_GrabObjCmd, grab current gives correct information} -body { set curr [grab current .] if { [string length $curr] > 0 } { grab release $curr } grab . - set curr [grab current] + grab current +} -cleanup { grab release . - set curr -} "." +} -result {.} -test grab-4.1 {Tk_GrabObjCmd, grab release releases grab} { + +test grab-4.1 {Tk_GrabObjCmd, grab release releases grab} -body { set curr [grab current .] if { [string length $curr] > 0 } { grab release $curr @@ -155,28 +160,31 @@ test grab-4.1 {Tk_GrabObjCmd, grab release releases grab} { lappend result [grab status .] grab release . lappend result [grab status .] -} [list "local" "none" "global" "none"] +} -result {local none global none} + -test grab-5.1 {Tk_GrabObjCmd, grab set} { +test grab-5.1 {Tk_GrabObjCmd, grab set} -body { set curr [grab current .] if { [string length $curr] > 0 } { grab release $curr } grab set . - set result [list [grab current .] [grab status .]] + list [grab current .] [grab status .] +} -cleanup { grab release . - set result -} [list "." "local"] -test grab-5.2 {Tk_GrabObjCmd, grab set} { +} -result {. local} +test grab-5.2 {Tk_GrabObjCmd, grab set} -body { set curr [grab current .] if { [string length $curr] > 0 } { grab release $curr } grab set -global . - set result [list [grab current .] [grab status .]] + list [grab current .] [grab status .] +} -cleanup { grab release . - set result -} [list "." "global"] +} -result {. global} + cleanupTests return + diff --git a/tests/grid.test b/tests/grid.test index a8b72cc..e058ec3 100644 --- a/tests/grid.test +++ b/tests/grid.test @@ -5,17 +5,20 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: grid.test,v 1.32 2008/07/23 23:24:25 nijtmans Exp $ +# RCS: @(#) $Id: grid.test,v 1.33 2008/08/16 23:52:34 aniap Exp $ -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test + # helper routine to return "." to a sane state after a test # The variable GRID_VERBOSE can be used to "look" at the result # of one or all of the tests proc grid_reset {{test ?} {top .}} { +#puts "AAA$test" global GRID_VERBOSE if {[info exists GRID_VERBOSE]} { if {$GRID_VERBOSE=="" || $GRID_VERBOSE==$test} { @@ -41,87 +44,78 @@ proc grid_reset {{test ?} {top .}} { grid_reset 0.0 wm geometry . {} -test grid-1.1 {basic argument checking} { - list [catch grid msg] $msg -} {1 {wrong # args: should be "grid option arg ?arg ...?"}} - -test grid-1.2 {basic argument checking} { - list [catch {grid foo bar} msg] $msg -} {1 {bad option "foo": must be anchor, bbox, columnconfigure, configure, forget, info, location, propagate, remove, rowconfigure, size, or slaves}} - -test grid-1.3 {basic argument checking} { +test grid-1.1 {basic argument checking} -body { + grid +} -returnCodes error -result {wrong # args: should be "grid option arg ?arg ...?"} +test grid-1.2 {basic argument checking} -body { + grid foo bar +} -returnCodes error -result {bad option "foo": must be anchor, bbox, columnconfigure, configure, forget, info, location, propagate, remove, rowconfigure, size, or slaves} +test grid-1.3 {basic argument checking} -body { button .b - list [catch {grid .b -row 0 -column} msg] $msg -} {1 {extra option or option with no value}} -grid_reset 1.3 + grid .b -row 0 -column +} -cleanup { + grid_reset 1.3 +} -returnCodes error -result {extra option or option with no value} -test grid-1.4 {basic argument checking} { +test grid-1.4 {basic argument checking} -body { button .b - list [catch {grid configure .b - foo} msg] $msg -} {1 {unexpected parameter, "foo", in configure list. Should be window name or option}} -grid_reset 1.4 - -test grid-1.5 {basic argument checking} { - list [catch {grid .} msg] $msg -} {1 {can't manage ".": it's a top-level window}} - -test grid-1.6 {basic argument checking} { - list [catch {grid x} msg] $msg -} {1 {can't determine master window}} - -test grid-1.7 {basic argument checking} { - list [catch {grid configure x} msg] $msg -} {1 {can't determine master window}} - -test grid-1.8 {basic argument checking} { + grid configure .b - foo +} -cleanup { + grid_reset 1.4 +} -returnCodes error -result {unexpected parameter, "foo", in configure list. Should be window name or option} +test grid-1.5 {basic argument checking} -body { + grid . +} -returnCodes error -result {can't manage ".": it's a top-level window} +test grid-1.6 {basic argument checking} -body { + grid x +} -returnCodes error -result {can't determine master window} +test grid-1.7 {basic argument checking} -body { + grid configure x +} -returnCodes error -result {can't determine master window} +test grid-1.8 {basic argument checking} -body { button .b - list [catch {grid x .b} msg] $msg -} {0 {}} -grid_reset 1.8 + grid x .b +} -cleanup { + grid_reset 1.8 +} -returnCodes ok -result {} -test grid-1.9 {basic argument checking} { +test grid-1.9 {basic argument checking} -body { button .b - list [catch {grid configure x .b} msg] $msg -} {0 {}} -grid_reset 1.9 + grid configure x .b +} -cleanup { + grid_reset 1.9 +} -returnCodes ok -result {} -test grid-2.1 {bbox} { - list [catch {grid bbox .} msg] $msg -} {0 {0 0 0 0}} -test grid-2.2 {bbox} { +test grid-2.1 {bbox} -body { + grid bbox . +} -result {0 0 0 0} +test grid-2.2 {bbox} -body { button .b grid .b destroy .b update - list [catch {grid bbox .} msg] $msg -} {0 {0 0 0 0}} - -test grid-2.3 {bbox: argument checking} { - list [catch {grid bbox . 0 0 5} msg] $msg -} {1 {wrong # args: should be "grid bbox master ?column row ?column row??"}} - -test grid-2.4 {bbox} { - list [catch {grid bbox .bad 0 0} msg] $msg -} {1 {bad window path name ".bad"}} - -test grid-2.5 {bbox} { - list [catch {grid bbox . x 0} msg] $msg -} {1 {expected integer but got "x"}} - -test grid-2.6 {bbox} { - list [catch {grid bbox . 0 x} msg] $msg -} {1 {expected integer but got "x"}} - -test grid-2.7 {bbox} { - list [catch {grid bbox . 0 0 x 0} msg] $msg -} {1 {expected integer but got "x"}} - -test grid-2.8 {bbox} { - list [catch {grid bbox . 0 0 0 x} msg] $msg -} {1 {expected integer but got "x"}} - -test grid-2.9 {bbox} { + grid bbox . +} -result {0 0 0 0} +test grid-2.3 {bbox: argument checking} -body { + grid bbox . 0 0 5 +} -returnCodes error -result {wrong # args: should be "grid bbox master ?column row ?column row??"} +test grid-2.4 {bbox} -body { + grid bbox .bad 0 0 +} -returnCodes error -result {bad window path name ".bad"} +test grid-2.5 {bbox} -body { + grid bbox . x 0 +} -returnCodes error -result {expected integer but got "x"} +test grid-2.6 {bbox} -body { + grid bbox . 0 x +} -returnCodes error -result {expected integer but got "x"} +test grid-2.7 {bbox} -body { + grid bbox . 0 0 x 0 +} -returnCodes error -result {expected integer but got "x"} +test grid-2.8 {bbox} -body { + grid bbox . 0 0 0 x +} -returnCodes error -result {expected integer but got "x"} +test grid-2.9 {bbox} -body { frame .1 -width 75 -height 75 -bg red frame .2 -width 90 -height 90 -bg red grid .1 -row 0 -column 0 @@ -133,10 +127,11 @@ test grid-2.9 {bbox} { lappend a [grid bbox . 0 0 1 1] lappend a [grid bbox . 1 1] set a -} {{0 0 165 165} {0 0 75 75} {0 0 165 165} {75 75 90 90}} -grid_reset 2.9 +} -cleanup { + grid_reset 2.9 +} -result {{0 0 165 165} {0 0 75 75} {0 0 165 165} {75 75 90 90}} -test grid-2.10 {bbox} { +test grid-2.10 {bbox} -body { frame .1 -width 75 -height 75 -bg red frame .2 -width 90 -height 90 -bg red grid .1 -row 0 -column 0 @@ -147,97 +142,109 @@ test grid-2.10 {bbox} { lappend a [grid bbox . -2 -2 -1 -1] lappend a [grid bbox . 10 10 12 12] set a -} {{0 0 165 165} {0 0 0 0} {165 165 0 0}} -grid_reset 2.10 +} -cleanup { + grid_reset 2.10 +} -result {{0 0 165 165} {0 0 0 0} {165 165 0 0}} -test grid-3.1 {configure: basic argument checking} { - list [catch {grid configure foo} msg] $msg -} {1 {bad argument "foo": must be name of window}} -test grid-3.2 {configure: basic argument checking} { +test grid-3.1 {configure: basic argument checking} -body { + grid configure foo +} -returnCodes error -result {bad argument "foo": must be name of window} +test grid-3.2 {configure: basic argument checking} -body { button .b grid configure .b grid slaves . -} {.b} -grid_reset 3.2 +} -cleanup { + grid_reset 3.2 +} -result {.b} -test grid-3.3 {configure: basic argument checking} { +test grid-3.3 {configure: basic argument checking} -body { button .b - list [catch {grid .b -row -1} msg] $msg -} {1 {bad row value "-1": must be a non-negative integer}} -grid_reset 3.3 + grid .b -row -1 +} -cleanup { + grid_reset 3.3 +} -returnCodes error -result {bad row value "-1": must be a non-negative integer} -test grid-3.4 {configure: basic argument checking} { +test grid-3.4 {configure: basic argument checking} -body { button .b - list [catch {grid .b -column -1} msg] $msg -} {1 {bad column value "-1": must be a non-negative integer}} -grid_reset 3.4 + grid .b -column -1 +} -cleanup { + grid_reset 3.4 +} -returnCodes error -result {bad column value "-1": must be a non-negative integer} -test grid-3.5 {configure: basic argument checking} { +test grid-3.5 {configure: basic argument checking} -body { button .b - list [catch {grid .b -rowspan 0} msg] $msg -} {1 {bad rowspan value "0": must be a positive integer}} -grid_reset 3.5 + grid .b -rowspan 0 +} -cleanup { + grid_reset 3.5 +} -returnCodes error -result {bad rowspan value "0": must be a positive integer} -test grid-3.6 {configure: basic argument checking} { +test grid-3.6 {configure: basic argument checking} -body { button .b - list [catch {grid .b -columnspan 0} msg] $msg -} {1 {bad columnspan value "0": must be a positive integer}} -grid_reset 3.6 + grid .b -columnspan 0 +} -cleanup { + grid_reset 3.6 +} -returnCodes error -result {bad columnspan value "0": must be a positive integer} -test grid-3.7 {configure: basic argument checking} { +test grid-3.7 {configure: basic argument checking} -body { frame .f button .f.b - list [catch {grid .f .f.b} msg] $msg -} {1 {can't put .f.b inside .}} -grid_reset 3.7 + grid .f .f.b +} -cleanup { + grid_reset 3.7 +} -returnCodes error -result {can't put .f.b inside .} -test grid-3.8 {configure: basic argument checking} { +test grid-3.8 {configure: basic argument checking} -body { button .b grid configure x .b grid slaves . -} {.b} -grid_reset 3.8 +} -cleanup { + grid_reset 3.8 +} -result {.b} -test grid-3.9 {configure: basic argument checking} { +test grid-3.9 {configure: basic argument checking} -body { button .b - list [catch {grid configure y .b} msg] $msg -} {1 {invalid window shortcut, "y" should be '-', 'x', or '^'}} -grid_reset 3.9 + grid configure y .b +} -cleanup { + grid_reset 3.9 +} -returnCodes error -result {invalid window shortcut, "y" should be '-', 'x', or '^'} -test grid-4.1 {forget: basic argument checking} { - list [catch {grid forget foo} msg] $msg -} {1 {bad window path name "foo"}} -test grid-4.2 {forget} { +test grid-4.1 {forget: basic argument checking} -body { + grid forget foo +} -returnCodes error -result {bad window path name "foo"} +test grid-4.2 {forget} -body { button .c grid [button .b] set a [grid slaves .] grid forget .b .c lappend a [grid slaves .] set a -} {.b {}} -grid_reset 4.2 +} -cleanup { + grid_reset 4.2 +} -result {.b {}} -test grid-4.3 {forget} { +test grid-4.3 {forget} -body { button .c grid .c -row 2 -column 2 -rowspan 2 -columnspan 2 -padx 3 -pady 4 -sticky ns grid forget .c grid .c -row 0 -column 0 grid info .c -} {-in . -column 0 -row 0 -columnspan 1 -rowspan 1 -ipadx 0 -ipady 0 -padx 0 -pady 0 -sticky {}} -grid_reset 4.3 +} -cleanup { + grid_reset 4.3 +} -result {-in . -column 0 -row 0 -columnspan 1 -rowspan 1 -ipadx 0 -ipady 0 -padx 0 -pady 0 -sticky {}} -test grid-4.3.1 {forget} { +test grid-4.4 {forget} -body { button .c grid .c -row 2 -column 2 -rowspan 2 -columnspan 2 -padx {3 5} -pady {4 7} -sticky ns grid forget .c grid .c -row 0 -column 0 grid info .c -} {-in . -column 0 -row 0 -columnspan 1 -rowspan 1 -ipadx 0 -ipady 0 -padx 0 -pady 0 -sticky {}} -grid_reset 4.3.1 +} -cleanup { + grid_reset 4.3.1 +} -result {-in . -column 0 -row 0 -columnspan 1 -rowspan 1 -ipadx 0 -ipady 0 -padx 0 -pady 0 -sticky {}} -test grid-4.4 {forget, calling Tk_UnmaintainGeometry} { +test grid-4.5 {forget, calling Tk_UnmaintainGeometry} -body { frame .f -bd 2 -relief raised place .f -x 10 -y 20 -width 200 -height 100 frame .f2 -width 50 -height 30 -bg red @@ -248,59 +255,61 @@ test grid-4.4 {forget, calling Tk_UnmaintainGeometry} { place .f -x 30 update lappend x [winfo ismapped .f2] -} {1 0} -grid_reset 4.4 +} -cleanup { + grid_reset 4.4 +} -result {1 0} -test grid-5.1 {info: basic argument checking} { - list [catch {grid info a b} msg] $msg -} {1 {wrong # args: should be "grid info window"}} -test grid-5.2 {info} { +test grid-5.1 {info: basic argument checking} -body { + grid info a b +} -returnCodes error -result {wrong # args: should be "grid info window"} +test grid-5.2 {info} -body { frame .1 -width 75 -height 75 -bg red grid .1 -row 0 -column 0 update - list [catch {grid info .x} msg] $msg -} {1 {bad window path name ".x"}} -grid_reset 5.2 + grid info .x +} -cleanup { + grid_reset 5.2 +} -returnCodes error -result {bad window path name ".x"} -test grid-5.3 {info} { +test grid-5.3 {info} -body { frame .1 -width 75 -height 75 -bg red grid .1 -row 0 -column 0 update - list [catch {grid info .1} msg] $msg -} {0 {-in . -column 0 -row 0 -columnspan 1 -rowspan 1 -ipadx 0 -ipady 0 -padx 0 -pady 0 -sticky {}}} -grid_reset 5.3 + grid info .1 +} -cleanup { + grid_reset 5.3 +} -result {-in . -column 0 -row 0 -columnspan 1 -rowspan 1 -ipadx 0 -ipady 0 -padx 0 -pady 0 -sticky {}} -test grid-5.4 {info} { +test grid-5.4 {info} -body { frame .1 -width 75 -height 75 -bg red update - list [catch {grid info .1} msg] $msg -} {0 {}} -grid_reset 5.4 - -test grid-6.1 {location: basic argument checking} { - list [catch "grid location ." msg] $msg -} {1 {wrong # args: should be "grid location master x y"}} - -test grid-6.2 {location: basic argument checking} { - list [catch "grid location .bad 0 0" msg] $msg -} {1 {bad window path name ".bad"}} - -test grid-6.3 {location: basic argument checking} { - list [catch "grid location . x y" msg] $msg -} {1 {bad screen distance "x"}} - -test grid-6.4 {location: basic argument checking} { - list [catch "grid location . 1c y" msg] $msg -} {1 {bad screen distance "y"}} - -test grid-6.5 {location: basic argument checking} { + grid info .1 +} -cleanup { + grid_reset 5.4 +} -returnCodes ok -result {} + + +test grid-6.1 {location: basic argument checking} -body { + grid location . +} -returnCodes error -result {wrong # args: should be "grid location master x y"} +test grid-6.2 {location: basic argument checking} -body { + grid location .bad 0 0 +} -returnCodes error -result {bad window path name ".bad"} +test grid-6.3 {location: basic argument checking} -body { + grid location . x y +} -returnCodes error -result {bad screen distance "x"} +test grid-6.4 {location: basic argument checking} -body { + grid location . 1c y +} -returnCodes error -result {bad screen distance "y"} +test grid-6.5 {location: basic argument checking} -body { frame .f grid location .f 10 10 -} {-1 -1} -grid_reset 6.5 +} -cleanup { + grid_reset 6.5 +} -result {-1 -1} -test grid-6.6 {location (x)} { +test grid-6.6 {location (x)} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red grid .f update @@ -314,10 +323,11 @@ test grid-6.6 {location (x)} { } } set result -} {{-10->-1 0} {0->0 0} {201->1 0}} -grid_reset 6.6 +} -cleanup { + grid_reset 6.6 +} -result {{-10->-1 0} {0->0 0} {201->1 0}} -test grid-6.7 {location (y)} { +test grid-6.7 {location (y)} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red grid .f update @@ -331,10 +341,11 @@ test grid-6.7 {location (y)} { } } set result -} {{-10->0 -1} {0->0 0} {101->0 1}} -grid_reset 6.7 +} -cleanup { + grid_reset 6.7 +} -result {{-10->0 -1} {0->0 0} {101->0 1}} -test grid-6.8 {location (weights)} { +test grid-6.8 {location (weights)} -body { frame .f -width 300 -height 100 -highlightthickness 0 -bg red frame .a grid .a @@ -354,10 +365,13 @@ test grid-6.8 {location (weights)} { } } set result -} {{-10->-1 -1} {0->0 0} {16->0 1} {201->1 1}} -grid_reset 6.8 +} -cleanup { + grid_reset 6.8 +} -result {{-10->-1 -1} {0->0 0} {16->0 1} {201->1 1}} -test grid-6.9 {location: check updates pending} {nonPortable} { +test grid-6.9 {location: check updates pending} -constraints { + nonPortable +} -body { set a "" foreach i {0 1 2} { frame .$i -width 120 -height 75 -bg red @@ -365,35 +379,42 @@ test grid-6.9 {location: check updates pending} {nonPortable} { grid .$i -row $i -column $i } set a -} {{0 0} {1 1} {1 1}} -grid_reset 6.9 - -test grid-7.1 {propagate} { - list [catch {grid propagate . 1 xxx} msg] $msg -} {1 {wrong # args: should be "grid propagate window ?boolean?"}} -grid_reset 7.1 - -test grid-7.2 {propagate} { - list [catch {grid propagate .} msg] $msg -} {0 1} -grid_reset 7.2 - -test grid-7.3 {propagate} { - list [catch {grid propagate . 0;grid propagate .} msg] $msg -} {0 0} -grid_reset 7.3 - -test grid-7.4 {propagate} { - list [catch {grid propagate .x} msg] $msg -} {1 {bad window path name ".x"}} -grid_reset 7.4 - -test grid-7.5 {propagate} { - list [catch {grid propagate . x} msg] $msg -} {1 {expected boolean value but got "x"}} -grid_reset 7.5 - -test grid-7.6 {propagate} { +} -cleanup { + grid_reset 6.9 +} -result {{0 0} {1 1} {1 1}} + + +test grid-7.1 {propagate} -body { + grid propagate . 1 xxx +} -cleanup { + grid_reset 7.1 +} -returnCodes error -result {wrong # args: should be "grid propagate window ?boolean?"} + +test grid-7.2 {propagate} -body { + grid propagate . +} -cleanup { + grid_reset 7.2 +} -result {1} + +test grid-7.3 {propagate} -body { + grid propagate . 0;grid propagate . +} -cleanup { + grid_reset 7.3 +} -result {0} + +test grid-7.4 {propagate} -body { + grid propagate .x +} -cleanup { + grid_reset 7.4 +} -returnCodes error -result {bad window path name ".x"} + +test grid-7.5 {propagate} -body { + grid propagate . x +} -cleanup { + grid_reset 7.5 +} -returnCodes error -result {expected boolean value but got "x"} + +test grid-7.6 {propagate} -body { frame .f -width 100 -height 100 -bg red grid .f -row 0 -column 0 update @@ -407,9 +428,10 @@ test grid-7.6 {propagate} { update lappend a [winfo width .f]x[winfo height .f] set a -} {100x100 100x100 75x85} -grid_reset 7.6 -test grid-7.7 {propagate} { +} -cleanup { + grid_reset 7.6 +} -result {100x100 100x100 75x85} +test grid-7.7 {propagate} -body { grid propagate . 1 set res [list [grid propagate .]] grid propagate . 0 @@ -417,26 +439,31 @@ test grid-7.7 {propagate} { grid propagate . 0 lappend res [grid propagate .] set res -} [list 1 0 0] -grid_reset 7.7 +} -cleanup { + grid_reset 7.7 +} -result [list 1 0 0] + -test grid-8.1 {size} { - list [catch {grid size . foo} msg] $msg -} {1 {wrong # args: should be "grid size window"}} -grid_reset 8.1 +test grid-8.1 {size} -body { + grid size . foo +} -cleanup { + grid_reset 8.1 +} -returnCodes error -result {wrong # args: should be "grid size window"} -test grid-8.2 {size} { - list [catch {grid size .x} msg] $msg -} {1 {bad window path name ".x"}} -grid_reset 8.2 +test grid-8.2 {size} -body { + grid size .x +} -cleanup { + grid_reset 8.2 +} -returnCodes error -result {bad window path name ".x"} -test grid-8.3 {size} { +test grid-8.3 {size} -body { frame .f - list [catch {grid size .f} msg] $msg -} {0 {0 0}} -grid_reset 8.3 + grid size .f +} -cleanup { + grid_reset 8.3 +} -result {0 0} -test grid-8.4 {size} { +test grid-8.4 {size} -body { catch {unset a} scale .f grid .f -row 0 -column 0 @@ -452,10 +479,11 @@ test grid-8.4 {size} { update lappend a [grid size .] set a -} {{1 1} {6 5} {664 948} {1 1}} -grid_reset 8.4 +} -cleanup { + grid_reset 8.4 +} -result {{1 1} {6 5} {664 948} {1 1}} -test grid-8.5 {size} { +test grid-8.5 {size} -body { catch {unset a} scale .f grid .f -row 0 -column 0 @@ -472,10 +500,11 @@ test grid-8.5 {size} { update lappend a [grid size .] set a -} {{1 1} {1 18} {64 18} {1 1}} -grid_reset 8.5 +} -cleanup { + grid_reset 8.5 +} -result {{1 1} {1 18} {64 18} {1 1}} -test grid-8.6 {size} { +test grid-8.6 {size} -body { catch {unset a} scale .f grid .f -row 10 -column 50 @@ -498,55 +527,49 @@ test grid-8.6 {size} { update lappend a [grid size .] set a -} {{51 11} {51 11} {31 11} {21 11} {16 1} {1 1}} -grid_reset 8.6 - -test grid-9.1 {slaves} { - list [catch {grid slaves .} msg] $msg -} {0 {}} - -test grid-9.2 {slaves} { - list [catch {grid slaves .foo} msg] $msg -} {1 {bad window path name ".foo"}} - -test grid-9.3 {slaves} { - list [catch {grid slaves a b} msg] $msg -} {1 {wrong # args: should be "grid slaves window ?-option value ...?"}} - -test grid-9.4 {slaves} { - list [catch {grid slaves . a b} msg] $msg -} {1 {bad option "a": must be -column or -row}} - -test grid-9.5 {slaves} { - list [catch {grid slaves . -column x} msg] $msg -} {1 {expected integer but got "x"}} - -test grid-9.6 {slaves} { - list [catch {grid slaves . -row -3} msg] $msg -} {1 {-row is an invalid value: should NOT be < 0}} - -test grid-9.7 {slaves} { - list [catch {grid slaves . -foo 3} msg] $msg -} {1 {bad option "-foo": must be -column or -row}} - -test grid-9.8 {slaves} { - list [catch {grid slaves .x -row 3} msg] $msg -} {1 {bad window path name ".x"}} - -test grid-9.9 {slaves} { - list [catch {grid slaves . -row 3} msg] $msg -} {0 {}} - -test grid-9.10 {slaves} { +} -cleanup { + grid_reset 8.6 +} -result {{51 11} {51 11} {31 11} {21 11} {16 1} {1 1}} + + +test grid-9.1 {slaves} -body { + grid slaves . +} -returnCodes ok -result {} +test grid-9.2 {slaves} -body { + grid slaves .foo +} -returnCodes error -result {bad window path name ".foo"} +test grid-9.3 {slaves} -body { + grid slaves a b +} -returnCodes error -result {wrong # args: should be "grid slaves window ?-option value ...?"} +test grid-9.4 {slaves} -body { + grid slaves . a b +} -returnCodes error -result {bad option "a": must be -column or -row} +test grid-9.5 {slaves} -body { + grid slaves . -column x +} -returnCodes error -result {expected integer but got "x"} +test grid-9.6 {slaves} -body { + grid slaves . -row -3 +} -returnCodes error -result {-row is an invalid value: should NOT be < 0} +test grid-9.7 {slaves} -body { + grid slaves . -foo 3 +} -returnCodes error -result {bad option "-foo": must be -column or -row} +test grid-9.8 {slaves} -body { + grid slaves .x -row 3 +} -returnCodes error -result {bad window path name ".x"} +test grid-9.9 {slaves} -body { + grid slaves . -row 3 +} -returnCodes ok -result {} +test grid-9.10 {slaves} -body { foreach i {0 1 2} { label .$i -text $i grid .$i -row $i -column $i } - list [catch {grid slaves .} msg] $msg -} {0 {.2 .1 .0}} -grid_reset 9.10 + grid slaves . +} -cleanup { + grid_reset 9.10 +} -result {.2 .1 .0} -test grid-9.11 {slaves} { +test grid-9.11 {slaves} -body { catch {unset a} foreach i {0 1 2} { label .$i -text $i @@ -561,95 +584,112 @@ test grid-9.11 {slaves} { lappend a $col{[grid slaves . -column $col]} } set a -} {{0{.0-x .0}} {1{.1-x .1}} {2{.2-x .2}} 3{} 0{.0} {1{.1 .0-x}} {2{.2 .1-x}} 3{.2-x}} -grid_reset 9.11 +} -cleanup { + grid_reset 9.11 +} -result {{0{.0-x .0}} {1{.1-x .1}} {2{.2-x .2}} 3{} 0{.0} {1{.1 .0-x}} {2{.2 .1-x}} 3{.2-x}} -# column/row configure -test grid-10.1 {column/row configure} { - list [catch {grid columnconfigure .} msg] $msg -} {1 {wrong # args: should be "grid columnconfigure master index ?-option value ...?"}} -grid_reset 10.1 - -test grid-10.2 {column/row configure} { - list [catch {grid columnconfigure . 0 -weight 0 -pad} msg] $msg -} {1 {wrong # args: should be "grid columnconfigure master index ?-option value ...?"}} -grid_reset 10.2 - -test grid-10.3 {column/row configure} { - list [catch {grid columnconfigure .f 0 -weight} msg] $msg -} {1 {bad window path name ".f"}} -grid_reset 10.3 - -test grid-10.4 {column/row configure} { - list [catch {grid columnconfigure . nine -weight} msg] $msg -} {1 {expected integer but got "nine" (when retreiving options only integer indices are allowed)}} -grid_reset 10.4 - -test grid-10.5 {column/row configure} { - list [catch {grid columnconfigure . 265 -weight} msg] $msg -} {0 0} -grid_reset 10.5 - -test grid-10.6 {column/row configure} { - list [catch {grid columnconfigure . 0} msg] $msg -} {0 {-minsize 0 -pad 0 -uniform {} -weight 0}} -grid_reset 10.6 - -test grid-10.7 {column/row configure} { - list [catch {grid columnconfigure . 0 -foo} msg] $msg -} {1 {bad option "-foo": must be -minsize, -pad, -uniform, or -weight}} -grid_reset 10.7 - -test grid-10.8 {column/row configure} { - list [catch {grid columnconfigure . 0 -minsize foo} msg] $msg -} {1 {bad screen distance "foo"}} -grid_reset 10.8 - -test grid-10.9 {column/row configure} { - list [catch {grid columnconfigure . 0 -minsize foo} msg] $msg -} {1 {bad screen distance "foo"}} -grid_reset 10.9 - -test grid-10.10 {column/row configure} { +# column/row configure +test grid-10.1 {column/row configure} -body { + grid columnconfigure . +} -cleanup { + grid_reset 10.1 +} -returnCodes error -result {wrong # args: should be "grid columnconfigure master index ?-option value ...?"} + +test grid-10.2 {column/row configure} -body { + grid columnconfigure . 0 -weight 0 -pad +} -cleanup { + grid_reset 10.2 +} -returnCodes error -result {wrong # args: should be "grid columnconfigure master index ?-option value ...?"} + +test grid-10.3 {column/row configure} -body { + grid columnconfigure .f 0 -weight +} -cleanup { + grid_reset 10.3 +} -returnCodes error -result {bad window path name ".f"} + +test grid-10.4 {column/row configure} -body { + grid columnconfigure . nine -weight +} -cleanup { + grid_reset 10.4 +} -returnCodes error -result {expected integer but got "nine" (when retreiving options only integer indices are allowed)} + +test grid-10.5 {column/row configure} -body { + grid columnconfigure . 265 -weight +} -cleanup { + grid_reset 10.5 +} -result {0} + +test grid-10.6 {column/row configure} -body { + grid columnconfigure . 0 +} -cleanup { + grid_reset 10.6 +} -result {-minsize 0 -pad 0 -uniform {} -weight 0} + +test grid-10.7 {column/row configure} -body { + grid columnconfigure . 0 -foo +} -cleanup { + grid_reset 10.7 +} -returnCodes error -result {bad option "-foo": must be -minsize, -pad, -uniform, or -weight} + +test grid-10.8 {column/row configure} -body { + grid columnconfigure . 0 -minsize foo +} -cleanup { + grid_reset 10.8 +} -returnCodes error -result {bad screen distance "foo"} + +test grid-10.9 {column/row configure} -body { + grid columnconfigure . 0 -minsize foo +} -cleanup { + grid_reset 10.9 +} -returnCodes error -result {bad screen distance "foo"} + +test grid-10.10 {column/row configure} -body { grid columnconfigure . 0 -minsize 10 grid columnconfigure . 0 -minsize -} {10} -grid_reset 10.10 - -test grid-10.11 {column/row configure} { - list [catch {grid columnconfigure . 0 -weight bad} msg] $msg -} {1 {expected integer but got "bad"}} -grid_reset 10.11 - -test grid-10.12 {column/row configure} { - list [catch {grid columnconfigure . 0 -weight -3} msg] $msg -} {1 {invalid arg "-weight": should be non-negative}} -grid_reset 10.12 - -test grid-10.13 {column/row configure} { +} -cleanup { + grid_reset 10.10 +} -result {10} + +test grid-10.11 {column/row configure} -body { + grid columnconfigure . 0 -weight bad +} -cleanup { + grid_reset 10.11 +} -returnCodes error -result {expected integer but got "bad"} + +test grid-10.12 {column/row configure} -body { + grid columnconfigure . 0 -weight -3 +} -cleanup { + grid_reset 10.12 +} -returnCodes error -result {invalid arg "-weight": should be non-negative} + +test grid-10.13 {column/row configure} -body { grid columnconfigure . 0 -weight 3 grid columnconfigure . 0 -weight -} {3} -grid_reset 10.13 - -test grid-10.14 {column/row configure} { - list [catch {grid columnconfigure . 0 -pad foo} msg] $msg -} {1 {bad screen distance "foo"}} -grid_reset 10.14 - -test grid-10.15 {column/row configure} { - list [catch {grid columnconfigure . 0 -pad -3} msg] $msg -} {1 {invalid arg "-pad": should be non-negative}} -grid_reset 10.15 - -test grid-10.16 {column/row configure} { +} -cleanup { + grid_reset 10.13 +} -result {3} + +test grid-10.14 {column/row configure} -body { + grid columnconfigure . 0 -pad foo +} -cleanup { + grid_reset 10.14 +} -returnCodes error -result {bad screen distance "foo"} + +test grid-10.15 {column/row configure} -body { + grid columnconfigure . 0 -pad -3 +} -cleanup { + grid_reset 10.15 +} -returnCodes error -result {invalid arg "-pad": should be non-negative} + +test grid-10.16 {column/row configure} -body { grid columnconfigure . 0 -pad 3 grid columnconfigure . 0 -pad -} {3} -grid_reset 10.16 +} -cleanup { + grid_reset 10.16 +} -result {3} -test grid-10.17 {column/row configure} { +test grid-10.17 {column/row configure} -body { frame .f set a "" grid columnconfigure .f 0 -weight 0 @@ -662,10 +702,11 @@ test grid-10.17 {column/row configure} { lappend a [grid columnconfigure .f 0 -weight] grid columnconfigure .f 0 -weight 0 set a -} {0 1 0 1} -grid_reset 10.17 +} -cleanup { + grid_reset 10.17 +} -result {0 1 0 1} -test grid-10.18 {column/row configure} { +test grid-10.18 {column/row configure} -body { frame .f grid columnconfigure .f {0 2} -minsize 10 -weight 1 list [grid columnconfigure .f 0 -minsize] \ @@ -674,32 +715,37 @@ test grid-10.18 {column/row configure} { [grid columnconfigure .f 0 -weight] \ [grid columnconfigure .f 1 -weight] \ [grid columnconfigure .f 2 -weight] -} {10 0 10 1 0 1} -grid_reset 10.18 +} -cleanup { + grid_reset 10.18 +} -result {10 0 10 1 0 1} -test grid-10.19 {column/row configure} { - list [catch {grid columnconfigure . {0 -1 2} -weight 1} msg] $msg -} {1 {grid columnconfigure: "-1" is out of range}} -grid_reset 10.19 +test grid-10.19 {column/row configure} -body { + grid columnconfigure . {0 -1 2} -weight 1 +} -cleanup { + grid_reset 10.19 +} -returnCodes error -result {grid columnconfigure: "-1" is out of range} -test grid-10.20 {column/row configure} { +test grid-10.20 {column/row configure} -body { grid columnconfigure . 0 -uniform foo grid columnconfigure . 0 -uniform -} {foo} -grid_reset 10.20 +} -cleanup { + grid_reset 10.20 +} -result {foo} -test grid-10.21 {column/row configure} { - list [catch {grid columnconfigure . .b -weight 1} msg] $msg -} {1 {grid columnconfigure: illegal index ".b"}} -grid_reset 10.21 +test grid-10.21 {column/row configure} -body { + grid columnconfigure . .b -weight 1 +} -cleanup { + grid_reset 10.21 +} -returnCodes error -result {grid columnconfigure: illegal index ".b"} -test grid-10.22 {column/row configure} { +test grid-10.22 {column/row configure} -body { button .b - list [catch {grid columnconfigure . .b -weight 1} msg] $msg -} {1 {grid columnconfigure: the window ".b" is not managed by "."}} -grid_reset 10.22 + grid columnconfigure . .b -weight 1 +} -cleanup { + grid_reset 10.22 +} -returnCodes error -result {grid columnconfigure: the window ".b" is not managed by "."} -test grid-10.23 {column/row configure} { +test grid-10.23 {column/row configure} -body { button .b grid .b -column 1 -columnspan 2 grid columnconfigure . .b -weight 1 @@ -708,10 +754,11 @@ test grid-10.23 {column/row configure} { lappend res [grid columnconfigure . $i -weight] } set res -} {0 1 1 0} -grid_reset 10.23 +} -cleanup { + grid_reset 10.23 +} -result {0 1 1 0} -test grid-10.24 {column/row configure} { +test grid-10.24 {column/row configure} -body { button .b button .c button .d @@ -725,10 +772,11 @@ test grid-10.24 {column/row configure} { lappend res [grid columnconfigure . $i -weight] } set res -} {0 1 2 2 2 1 0} -grid_reset 10.24 +} -cleanup { + grid_reset 10.24 +} -result {0 1 2 2 2 1 0} -test grid-10.25 {column/row configure} { +test grid-10.25 {column/row configure} -body { button .b button .c button .d @@ -742,46 +790,43 @@ test grid-10.25 {column/row configure} { lappend res [grid rowconfigure . $i -weight] } set res -} {0 2 1 1 2 2 0 1} -grid_reset 10.25 +} -cleanup { + grid_reset 10.25 +} -result {0 2 1 1 2 2 0 1} -test grid-10.26 {column/row configure} { +test grid-10.26 {column/row configure} -body { button .b grid columnconfigure .b 0 -} {-minsize 0 -pad 0 -uniform {} -weight 0} -grid_reset 10.26 +} -cleanup { + grid_reset 10.26 +} -result {-minsize 0 -pad 0 -uniform {} -weight 0} -test grid-10.30 {column/row configure - no indices} { +test grid-10.27 {column/row configure - no indices} -body { # Bug 1422430 set t [toplevel .test] - set res [list [catch {grid columnconfigure $t "" -weight 1} msg] $msg] + grid columnconfigure $t "" -weight 1 +} -cleanup { destroy $t - set res -} {1 {no column indices specified}} - -test grid-10.31 {column/row configure - no indices} { +} -returnCodes error -result {no column indices specified} +test grid-10.28 {column/row configure - no indices} -body { set t [toplevel .test] - set res [list [catch {grid rowconfigure $t "" -weight 1} msg] $msg] + grid rowconfigure $t "" -weight 1 +} -cleanup { destroy $t - set res -} {1 {no row indices specified}} - -test grid-10.32 {column/row configure - invalid indices} { - list [catch {grid columnconfigure . {0 1 2} -weight} msg] $msg -} {1 {grid columnconfigure: must specify a single element on retrieval}} - -test grid-10.33 {column/row configure - invalid indices} { - list [catch {grid rowconfigure . {0 1 2} -weight} msg] $msg -} {1 {grid rowconfigure: must specify a single element on retrieval}} - -test grid-10.34 {column/row configure - empty 'all' configure} { +} -returnCodes error -result {no row indices specified} +test grid-10.29 {column/row configure - invalid indices} -body { + grid columnconfigure . {0 1 2} -weight +} -returnCodes error -result {grid columnconfigure: must specify a single element on retrieval} +test grid-10.30 {column/row configure - invalid indices} -body { + grid rowconfigure . {0 1 2} -weight +} -returnCodes error -result {grid rowconfigure: must specify a single element on retrieval} +test grid-10.31 {column/row configure - empty 'all' configure} -body { # Bug 1422430 set t [toplevel .test] grid rowconfigure $t all -weight 1 destroy $t -} {} - -test grid-10.35 {column/row configure} { +} -result {} +test grid-10.32 {column/row configure} -body { # Test that no lingering message is there frame .f set res [grid columnconfigure .f all -weight 1] @@ -793,20 +838,23 @@ test grid-10.35 {column/row configure} { append res [grid columnconfigure .f {2 .f.f} -weight 1] destroy .f set res -} {} -grid_reset 10.35 - -test grid-10.36 {column/row configure} { - list [catch {grid columnconfigure . all} msg] $msg -} {1 {expected integer but got "all" (when retreiving options only integer indices are allowed)}} -grid_reset 10.36 - -test grid-10.37 {column/row configure} { - list [catch {grid columnconfigure . 100000} msg] $msg -} {0 {-minsize 0 -pad 0 -uniform {} -weight 0}} -grid_reset 10.37 - -test grid-10.38 {column/row configure} -body { +} -cleanup { + grid_reset 10.35 +} -result {} + +test grid-10.33 {column/row configure} -body { + grid columnconfigure . all +} -cleanup { + grid_reset 10.36 +} -returnCodes error -result {expected integer but got "all" (when retreiving options only integer indices are allowed)} + +test grid-10.34 {column/row configure} -body { + grid columnconfigure . 100000 +} -cleanup { + grid_reset 10.37 +} -result {-minsize 0 -pad 0 -uniform {} -weight 0} + +test grid-10.35 {column/row configure} -body { # This is a test for bug 1423666 where a column >= 10000 caused # a crash in layout. The update is needed to reach the layout stage. # Test different combinations of row/column overflow @@ -829,7 +877,7 @@ test grid-10.38 {column/row configure} -body { } 0 end] grid_reset 10.38 -test grid-10.39 {column/row configure} -body { +test grid-10.36 {column/row configure} -body { # Additional tests for row/column overflow frame .f frame .g @@ -851,38 +899,43 @@ test grid-10.39 {column/row configure} -body { } 0 end] grid_reset 10.39 -# auto-placement tests -test grid-11.1 {default widget placement} { - list [catch {grid ^} msg] $msg -} {1 {can't use '^', cant find master}} -grid_reset 11.1 +# auto-placement tests +test grid-11.1 {default widget placement} -body { + grid ^ +} -cleanup { + grid_reset 11.1 +} -returnCodes error -result {can't use '^', cant find master} -test grid-11.2 {default widget placement} { +test grid-11.2 {default widget placement} -body { button .b - list [catch {grid .b ^} msg] $msg -} {1 {can't find slave to extend with "^".}} -grid_reset 11.2 + grid .b ^ +} -cleanup { + grid_reset 11.2 +} -returnCodes error -result {can't find slave to extend with "^".} -test grid-11.3 {default widget placement} { +test grid-11.3 {default widget placement} -body { button .b - list [catch {grid .b - - .c} msg] $msg -} {1 {bad window path name ".c"}} -grid_reset 11.3 + grid .b - - .c +} -cleanup { + grid_reset 11.3 +} -returnCodes error -result {bad window path name ".c"} -test grid-11.4 {default widget placement} { +test grid-11.4 {default widget placement} -body { button .b - list [catch {grid .b - - = -} msg] $msg -} {1 {invalid window shortcut, "=" should be '-', 'x', or '^'}} -grid_reset 11.4 + grid .b - - = - +} -cleanup { + grid_reset 11.4 +} -returnCodes error -result {invalid window shortcut, "=" should be '-', 'x', or '^'} -test grid-11.5 {default widget placement} { +test grid-11.5 {default widget placement} -body { button .b - list [catch {grid .b - x -} msg] $msg -} {1 {Must specify window before shortcut '-'.}} -grid_reset 11.5 + grid .b - x - +} -cleanup { + grid_reset 11.5 +} -returnCodes error -result {Must specify window before shortcut '-'.} -test grid-11.6 {default widget placement} { +test grid-11.6 {default widget placement} -body { foreach i {1 2 3 4 5 6} { frame .f$i -width 50 -height 50 -highlightthickness 0 -bg red } @@ -895,31 +948,35 @@ test grid-11.6 {default widget placement} { [winfo width .f$i],[winfo height .f$i]" } set a -} {{0,50 100,50} {150,50 50,50}} -grid_reset 11.6 +} -cleanup { + grid_reset 11.6 +} -result {{0,50 100,50} {150,50 50,50}} -test grid-11.7 {default widget placement} { +test grid-11.7 {default widget placement} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red grid .f -row 5 -column 5 - list [catch "grid .f x -" msg] $msg -} {1 {Must specify window before shortcut '-'.}} -grid_reset 11.7 + grid .f x - +} -cleanup { + grid_reset 11.7 +} -returnCodes error -result {Must specify window before shortcut '-'.} -test grid-11.8 {default widget placement} { +test grid-11.8 {default widget placement} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red grid .f -row 5 -column 5 - list [catch "grid .f ^ -" msg] $msg -} {1 {Must specify window before shortcut '-'.}} -grid_reset 11.8 + grid .f ^ - +} -cleanup { + grid_reset 11.8 +} -returnCodes error -result {Must specify window before shortcut '-'.} -test grid-11.9 {default widget placement} { +test grid-11.9 {default widget placement} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red grid .f -row 5 -column 5 - list [catch "grid .f x ^" msg] $msg -} {1 {can't find slave to extend with "^".}} -grid_reset 11.9 + grid .f x ^ +} -cleanup { + grid_reset 11.9 +} -returnCodes error -result {can't find slave to extend with "^".} -test grid-11.10 {default widget placement} { +test grid-11.10 {default widget placement} -body { foreach i {1 2 3} { frame .f$i -width 100 -height 50 -highlightthickness 0 -bg red } @@ -932,10 +989,11 @@ test grid-11.10 {default widget placement} { [winfo width .f$i],[winfo height .f$i]" } set a -} {{0,0 100,50} {100,0 100,100} {0,50 100,50}} -grid_reset 11.10 +} -cleanup { + grid_reset 11.10 +} -result {{0,0 100,50} {100,0 100,100} {0,50 100,50}} -test grid-11.11 {default widget placement} { +test grid-11.11 {default widget placement} -body { foreach i {1 2 3 4 5 6 7 8 9 10 11 12} { frame .f$i -width 50 -height 50 -highlightthickness 1 -highlightbackground black } @@ -951,10 +1009,11 @@ test grid-11.11 {default widget placement} { [winfo width .f$i],[winfo height .f$i]" } set a -} {{0,50 50,50} {50,50 100,150} {150,50 50,50} {0,100 50,50} {150,100 50,50} {0,150 50,50} {150,150 50,50} {0,200 200,50}} -grid_reset 11.11 +} -cleanup { + grid_reset 11.11 +} -result {{0,50 50,50} {50,50 100,150} {150,50 50,50} {0,100 50,50} {150,100 50,50} {0,150 50,50} {150,150 50,50} {0,200 200,50}} -test grid-11.12 {default widget placement} { +test grid-11.12 {default widget placement} -body { foreach i {1 2 3 4} { frame .f$i -width 75 -height 50 -highlightthickness 1 -highlightbackground black } @@ -973,10 +1032,11 @@ test grid-11.12 {default widget placement} { [winfo width .f$i],[winfo height .f$i]" } set a -} {{0,0 75,50} {75,0 75,100} {150,0 75,50} {0,50 75,50} {0,0 75,50} {75,0 75,100} {150,0 75,100} {75,50 75,50}} -grid_reset 11.12 +} -cleanup { + grid_reset 11.12 +} -result {{0,0 75,50} {75,0 75,100} {150,0 75,50} {0,50 75,50} {0,0 75,50} {75,0 75,100} {150,0 75,100} {75,50 75,50}} -test grid-11.13 {default widget placement} { +test grid-11.13 {default widget placement} -body { foreach i {1 2 3 4 5 6 7} { frame .f$i -width 40 -height 50 -highlightthickness 1 -highlightbackground black } @@ -989,10 +1049,11 @@ test grid-11.13 {default widget placement} { [winfo width .f$i],[winfo height .f$i]" } set a -} {{0,50 120,50} {120,50 80,50}} -grid_reset 11.13 +} -cleanup { + grid_reset 11.13 +} -result {{0,50 120,50} {120,50 80,50}} -test grid-11.14 {default widget placement} { +test grid-11.14 {default widget placement} -body { foreach i {1 2 3} { frame .f$i -width 60 -height 60 -highlightthickness 0 -bg red } @@ -1005,10 +1066,11 @@ test grid-11.14 {default widget placement} { [winfo width .f$i],[winfo height .f$i]" } set a -} {{0,30 60,60} {60,0 60,60} {60,60 60,60}} -grid_reset 11.14 +} -cleanup { + grid_reset 11.14 +} -result {{0,30 60,60} {60,0 60,60} {60,60 60,60}} -test grid-11.15 {^ ^ test with multiple windows} { +test grid-11.15 {^ ^ test with multiple windows} -body { foreach i {1 2 3 4} { frame .f$i -width 50 -height 50 -bd 1 -relief solid } @@ -1021,10 +1083,11 @@ test grid-11.15 {^ ^ test with multiple windows} { [winfo width .f$i],[winfo height .f$i]" } set a -} {{0,0 50,50} {50,0 50,100} {100,0 50,100} {0,50 50,50}} -grid_reset 11.15 +} -cleanup { + grid_reset 11.15 +} -result {{0,0 50,50} {50,0 50,100} {100,0 50,100} {0,50 50,50}} -test grid-11.16 {default widget placement} { +test grid-11.16 {default widget placement} -body { foreach l {a b c d e} { frame .$l -width 50 -height 50 } @@ -1035,10 +1098,11 @@ test grid-11.16 {default widget placement} { lappend res [winfo height .a] lappend res [winfo height .b] lappend res [winfo height .c] -} {50 100 50} -grid_reset 11.16 +} -cleanup { + grid_reset 11.16 +} -result {50 100 50} -test grid-11.17 {default widget placement} { +test grid-11.17 {default widget placement} -body { foreach l {a b c d e} { frame .$l -width 50 -height 50 } @@ -1049,10 +1113,11 @@ test grid-11.17 {default widget placement} { lappend res [winfo height .a] lappend res [winfo height .b] lappend res [winfo height .c] -} {100 50 100} -grid_reset 11.17 +} -cleanup { + grid_reset 11.17 +} -result {100 50 100} -test grid-11.18 {default widget placement} { +test grid-11.18 {default widget placement} -body { foreach l {a b c d e} { frame .$l -width 50 -height 50 } @@ -1065,10 +1130,11 @@ test grid-11.18 {default widget placement} { lappend res [winfo height .b] lappend res [winfo height .c] lappend res [winfo height .d] -} {100 100 100 50} -grid_reset 11.18 +} -cleanup { + grid_reset 11.18 +} -result {100 100 100 50} -test grid-11.19 {default widget placement} { +test grid-11.19 {default widget placement} -body { foreach l {a b c d e} { frame .$l -width 50 -height 50 } @@ -1084,10 +1150,12 @@ test grid-11.19 {default widget placement} { lappend res [winfo height .b] lappend res [winfo height .c] lappend res [winfo height .d] -} {50 100 100 50} -grid_reset 11.19 +} -cleanup { + grid_reset 11.19 +} -result {50 100 100 50} + -test grid-12.1 {-sticky} { +test grid-12.1 {-sticky} -body { catch {unset data} frame .f -width 200 -height 100 -highlightthickness 0 -bg red set a "" @@ -1103,7 +1171,9 @@ test grid-12.1 {-sticky} { append a "($data(-sticky)) [winfo x .f] [winfo y .f] [winfo width .f] [winfo height .f]\n" } set a -} {() 25 25 200 100 +} -cleanup { + grid_reset 12.1 +} -result {() 25 25 200 100 (n) 25 0 200 100 (s) 25 50 200 100 (e) 50 25 200 100 @@ -1120,63 +1190,71 @@ test grid-12.1 {-sticky} { (new) 0 0 250 100 (nesw) 0 0 250 150 } -grid_reset 12.1 -test grid-12.2 {-sticky} { +test grid-12.2 {-sticky} -body { frame .f -bg red - list [catch "grid .f -sticky glue" msg] $msg -} {1 {bad stickyness value "glue": must be a string containing n, e, s, and/or w}} -grid_reset 12.2 + grid .f -sticky glue +} -cleanup { + grid_reset 12.2 +} -returnCodes error -result {bad stickyness value "glue": must be a string containing n, e, s, and/or w} -test grid-12.3 {-sticky} { +test grid-12.3 {-sticky} -body { frame .f -bg red grid .f -sticky {n,s,e,w} array set A [grid info .f] set A(-sticky) -} {nesw} -grid_reset 12.3 +} -cleanup { + grid_reset 12.3 +} -result {nesw} -test grid-13.1 {-in} { + +test grid-13.1 {-in} -body { frame .f -bg red - list [catch "grid .f -in .f" msg] $msg -} {1 {Window can't be managed in itself}} -grid_reset 13.1 + grid .f -in .f +} -cleanup { + grid_reset 13.1 +} -returnCodes error -result {Window can't be managed in itself} -test grid-13.1.1 {-in} { +test grid-13.2 {-in} -body { frame .f -bg red list [winfo manager .f] \ [catch {grid .f -in .f} err] $err \ [winfo manager .f] -} {{} 1 {Window can't be managed in itself} {}} -grid_reset 13.1.1 +} -cleanup { + grid_reset 13.1.1 +} -result {{} 1 {Window can't be managed in itself} {}} -test grid-13.2 {-in} { +test grid-13.3 {-in} -body { frame .f -bg red - list [catch "grid .f -in .bad" msg] $msg -} {1 {bad window path name ".bad"}} -grid_reset 13.2 + grid .f -in .bad +} -cleanup { + grid_reset 13.2 +} -returnCodes error -result {bad window path name ".bad"} -test grid-13.3 {-in} { +test grid-13.4 {-in} -body { frame .f -bg red toplevel .top - list [catch "grid .f -in .top" msg] $msg -} {1 {can't put .f inside .top}} + grid .f -in .top +} -cleanup { + grid_reset 13.3 +} -returnCodes error -result {can't put .f inside .top} destroy .top -grid_reset 13.3 -test grid-13.4 {-ipadx} { +test grid-13.5 {-ipadx} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red - list [catch "grid .f -ipadx x" msg] $msg -} {1 {bad ipadx value "x": must be positive screen distance}} -grid_reset 13.4 + grid .f -ipadx x +} -cleanup { + grid_reset 13.4 +} -returnCodes error -result {bad ipadx value "x": must be positive screen distance} -test grid-13.4.1 {-ipadx} { +test grid-13.6 {-ipadx} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red - list [catch "grid .f -ipadx {5 5}" msg] $msg -} {1 {bad ipadx value "5 5": must be positive screen distance}} -grid_reset 13.4.1 + grid .f -ipadx {5 5} +} -cleanup { + grid_reset 13.4.1 +} -returnCodes error -result {bad ipadx value "5 5": must be positive screen distance} -test grid-13.5 {-ipadx} { +test grid-13.7 {-ipadx} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red grid .f update @@ -1184,22 +1262,25 @@ test grid-13.5 {-ipadx} { grid .f -ipadx 1 update list $a [winfo width .f] -} {200 202} -grid_reset 13.5 +} -cleanup { + grid_reset 13.5 +} -result {200 202} -test grid-13.6 {-ipady} { +test grid-13.8 {-ipady} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red - list [catch "grid .f -ipady x" msg] $msg -} {1 {bad ipady value "x": must be positive screen distance}} -grid_reset 13.6 + grid .f -ipady x +} -cleanup { + grid_reset 13.6 +} -returnCodes error -result {bad ipady value "x": must be positive screen distance} -test grid-13.6.1 {-ipady} { +test grid-13.9 {-ipady} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red - list [catch "grid .f -ipady {5 5}" msg] $msg -} {1 {bad ipady value "5 5": must be positive screen distance}} -grid_reset 13.6.1 + grid .f -ipady {5 5} +} -cleanup { + grid_reset 13.6.1 +} -returnCodes error -result {bad ipady value "5 5": must be positive screen distance} -test grid-13.7 {-ipady} { +test grid-13.10 {-ipady} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red grid .f update @@ -1207,22 +1288,25 @@ test grid-13.7 {-ipady} { grid .f -ipady 1 update list $a [winfo height .f] -} {100 102} -grid_reset 13.7 +} -cleanup { + grid_reset 13.7 +} -result {100 102} -test grid-13.8 {-padx} { +test grid-13.11 {-padx} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red - list [catch "grid .f -padx x" msg] $msg -} {1 {bad pad value "x": must be positive screen distance}} -grid_reset 13.8 + grid .f -padx x +} -cleanup { + grid_reset 13.8 +} -returnCodes error -result {bad pad value "x": must be positive screen distance} -test grid-13.8.1 {-padx} { +test grid-13.12 {-padx} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red - list [catch "grid .f -padx {10 x}" msg] $msg -} {1 {bad 2nd pad value "x": must be positive screen distance}} -grid_reset 13.8.1 + grid .f -padx {10 x} +} -cleanup { + grid_reset 13.8.1 +} -returnCodes error -result {bad 2nd pad value "x": must be positive screen distance} -test grid-13.9 {-padx} { +test grid-13.13 {-padx} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red grid .f update @@ -1230,10 +1314,11 @@ test grid-13.9 {-padx} { grid .f -padx 1 update list $a "[winfo width .f] [winfo width .] [winfo x .f]" -} {{200 200} {200 202 1}} -grid_reset 13.9 +} -cleanup { + grid_reset 13.9 +} -result {{200 200} {200 202 1}} -test grid-13.9.1 {-padx} { +test grid-13.14 {-padx} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red grid .f update @@ -1241,22 +1326,25 @@ test grid-13.9.1 {-padx} { grid .f -padx {10 5} update list $a "[winfo width .f] [winfo width .] [winfo x .f]" -} {{200 200} {200 215 10}} -grid_reset 13.9.1 +} -cleanup { + grid_reset 13.9.1 +} -result {{200 200} {200 215 10}} -test grid-13.10 {-pady} { +test grid-13.15 {-pady} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red - list [catch "grid .f -pady x" msg] $msg -} {1 {bad pad value "x": must be positive screen distance}} -grid_reset 13.10 + grid .f -pady x +} -cleanup { + grid_reset 13.10 +} -returnCodes error -result {bad pad value "x": must be positive screen distance} -test grid-13.10.1 {-pady} { +test grid-13.16 {-pady} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red - list [catch "grid .f -pady {10 x}" msg] $msg -} {1 {bad 2nd pad value "x": must be positive screen distance}} -grid_reset 13.10.1 + grid .f -pady {10 x} +} -cleanup { + grid_reset 13.10.1 +} -returnCodes error -result {bad 2nd pad value "x": must be positive screen distance} -test grid-13.11 {-pady} { +test grid-13.17 {-pady} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red grid .f update @@ -1264,10 +1352,11 @@ test grid-13.11 {-pady} { grid .f -pady 1 update list $a "[winfo height .f] [winfo height .] [winfo y .f]" -} {{100 100} {100 102 1}} -grid_reset 13.11 +} -cleanup { + grid_reset 13.11 +} -result {{100 100} {100 102 1}} -test grid-13.11.1 {-pady} { +test grid-13.18 {-pady} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red grid .f update @@ -1275,10 +1364,11 @@ test grid-13.11.1 {-pady} { grid .f -pady {4 16} update list $a "[winfo height .f] [winfo height .] [winfo y .f]" -} {{100 100} {100 120 4}} -grid_reset 13.11.1 +} -cleanup { + grid_reset 13.11.1 +} -result {{100 100} {100 120 4}} -test grid-13.12 {-ipad x and y} { +test grid-13.19 {-ipad x and y} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red grid columnconfigure . 0 -minsize 150 grid rowconfigure . 0 -minsize 100 @@ -1294,10 +1384,11 @@ test grid-13.12 {-ipad x and y} { } } set a -} { 0,0:,65,40,20,20 0,5:,65,35,20,30 5,0:,60,40,30,20 5,5:,60,35,30,30} -grid_reset 13.12 +} -cleanup { + grid_reset 13.12 +} -result { 0,0:,65,40,20,20 0,5:,65,35,20,30 5,0:,60,40,30,20 5,5:,60,35,30,30} -test grid-13.13 {reparenting} { +test grid-13.20 {reparenting} -body { frame .1 frame .2 button .b @@ -1311,10 +1402,12 @@ test grid-13.13 {reparenting} { lappend a [grid slaves .1],[grid slaves .2],$info(-in) unset info set a -} {.b,,.1 ,.b,.2} -grid_reset 13.13 +} -cleanup { + grid_reset 13.13 +} -result {.b,,.1 ,.b,.2} + -test grid-14.1 {structure notify} { +test grid-14.1 {structure notify} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red frame .g -width 200 -height 100 -highlightthickness 0 -bg red grid .f @@ -1328,10 +1421,11 @@ test grid-14.1 {structure notify} { lappend a "[winfo x .g],[winfo y .g] \ [winfo width .g],[winfo height .g]" set a -} {{0,0 200,100} {5,5 200,100}} -grid_reset 14.1 +} -cleanup { + grid_reset 14.1 +} -result {{0,0 200,100} {5,5 200,100}} -test grid-14.2 {structure notify} { +test grid-14.2 {structure notify} -body { frame .f -width 200 -height 100 frame .f.g -width 200 -height 100 grid .f @@ -1342,10 +1436,13 @@ test grid-14.2 {structure notify} { .f config -bd 20 update lappend a [grid bbox .],[grid bbox .f] -} {{0 0 200 100,0 0 200 100} {0 0 240 140,20 20 200 100}} -grid_reset 14.2 +} -cleanup { + grid_reset 14.2 +} -result {{0 0 200 100,0 0 200 100} {0 0 240 140,20 20 200 100}} -test grid-14.3 {map notify: bug 1648} {nonPortable} { +test grid-14.3 {map notify: bug 1648} -constraints { + nonPortable +} -body { # This test is nonPortable because the number of times # A(.) will be incremented is unspecified--the behavior # is different accross window managers. @@ -1364,10 +1461,12 @@ test grid-14.3 {map notify: bug 1648} {nonPortable} { update bind . <Configure> {} array get A -} {.2 2 .0 1 . 2 .1 1} -grid_reset 14.3 +} -cleanup { + grid_reset 14.3 +} -result {.2 2 .0 1 . 2 .1 1} -test grid-15.1 {lost slave} { + +test grid-15.1 {lost slave} -body { button .b grid .b set a [grid slaves .] @@ -1375,10 +1474,11 @@ test grid-15.1 {lost slave} { lappend a [grid slaves .] grid .b lappend a [grid slaves .] -} {.b {} .b} -grid_reset 15.1 +} -cleanup { + grid_reset 15.1 +} -result {.b {} .b} -test grid-15.2 {lost slave} { +test grid-15.2 {lost slave} -body { frame .f grid .f button .b @@ -1388,10 +1488,12 @@ test grid-15.2 {lost slave} { lappend a [grid slaves .f] grid .b -in .f lappend a [grid slaves .f] -} {.b {} .b} -grid_reset 15.2 +} -cleanup { + grid_reset 15.2 +} -result {.b {} .b} + -test grid-16.1 {layout centering} { +test grid-16.1 {layout centering} -body { foreach i {0 1 2} { frame .$i -bg gray -width 75 -height 50 -bd 2 -relief ridge grid .$i -row $i -column $i -sticky nswe @@ -1401,10 +1503,11 @@ test grid-16.1 {layout centering} { . configure -width 300 -height 250 update grid bbox . -} {37 50 225 150} -grid_reset 16.1 +} -cleanup { + grid_reset 16.1 +} -result {37 50 225 150} -test grid-16.2 {layout weights (expanding)} { +test grid-16.2 {layout weights (expanding)} -body { foreach i {0 1 2} { frame .$i -bg gray -width 75 -height 50 -bd 2 -relief ridge grid .$i -row $i -column $i -sticky nswe @@ -1419,12 +1522,13 @@ test grid-16.2 {layout weights (expanding)} { lappend a [winfo width .$i]-[winfo height .$i] } set a -} {120-75 167-100 213-125} -grid_reset 16.2 +} -cleanup { + grid_reset 16.2 +} -result {120-75 167-100 213-125} -test grid-16.3 {layout weights (shrinking)} { +test grid-16.3 {layout weights (shrinking)} -body { foreach i {0 1 2} { - frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge + frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge grid .$i -row $i -column $i -sticky nswe grid rowconfigure . $i -weight [expr $i + 1] grid columnconfigure . $i -weight [expr $i + 1] @@ -1437,10 +1541,11 @@ test grid-16.3 {layout weights (shrinking)} { lappend a [winfo width .$i]-[winfo height .$i] } set a -} {84-63 66-50 50-37} -grid_reset 16.3 +} -cleanup { + grid_reset 16.3 +} -result {84-63 66-50 50-37} -test grid-16.4 {layout weights (shrinking with minsize)} { +test grid-16.4 {layout weights (shrinking with minsize)} -body { foreach i {0 1 2} { frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge grid .$i -row $i -column $i -sticky nswe @@ -1455,10 +1560,11 @@ test grid-16.4 {layout weights (shrinking with minsize)} { lappend a [winfo width .$i]-[winfo height .$i] } set a -} {70-60 65-45 65-45} -grid_reset 16.4 +} -cleanup { + grid_reset 16.4 +} -result {70-60 65-45 65-45} -test grid-16.5 {layout weights (shrinking at minsize)} { +test grid-16.5 {layout weights (shrinking at minsize)} -body { foreach i {0 1 2} { frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge grid .$i -row $i -column $i -sticky nswe @@ -1473,11 +1579,12 @@ test grid-16.5 {layout weights (shrinking at minsize)} { lappend a [winfo width .$i]-[winfo height .$i] } set a -} {100-75 100-75 100-75} -grid_reset 16.5 +} -cleanup { + grid_reset 16.5 +} -result {100-75 100-75 100-75} -test grid-16.6 {layout weights (shrinking at minsize)} { +test grid-16.6 {layout weights (shrinking at minsize)} -body { foreach i {0 1 2} { frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge grid .$i -row $i -column $i -sticky nswe @@ -1492,10 +1599,17 @@ test grid-16.6 {layout weights (shrinking at minsize)} { lappend a [winfo width .$i]-[winfo height .$i] } set a -} {69-52 69-52 69-52} -grid_reset 16.6 - -test grid-16.7 {layout weights (shrinking at minsize)} { +} -cleanup { + grid_reset 16.6 +} -result {69-52 69-52 69-52} + +# test fails when run alone +# reason (I think): -minsize 0 causes both: +# [winfo ismapped .$i] => 0 and +# not responding for width ang height settings, so that +# [winfo width .$i] [winfo height .$i] take different values +# That doesn't happen if previous tests run +test grid-16.7 {layout weights (shrinking at minsize)} -body { foreach i {0 1 2} { frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge grid .$i -row $i -column $i -sticky nswe @@ -1503,17 +1617,18 @@ test grid-16.7 {layout weights (shrinking at minsize)} { grid propagate . 0 grid columnconfigure . 1 -weight 1 -minsize 0 grid rowconfigure . 1 -weight 1 -minsize 0 - . configure -width 100 -height 75 + . configure -width 100 -height 1 set a "" update foreach i {0 1 2} { lappend a [winfo width .$i]-[winfo height .$i]-[winfo ismapped .$i] } set a -} {100-75-1 1-1-0 100-75-1} -grid_reset 16.7 +} -cleanup { + grid_reset 16.7 +} -result {100-75-1 1-1-0 100-75-1} -test grid-16.8 {layout internal constraints} { +test grid-16.8 {layout internal constraints} -body { foreach i {0 1 2 3 4} { frame .$i -bg gray -width 30 -height 25 -bd 2 -relief ridge grid .$i -row $i -column $i -sticky nswe @@ -1549,10 +1664,11 @@ test grid-16.8 {layout internal constraints} { append a "[winfo x .$i] " } set a -} {0 30 130 230 280 , 0 30 130 230 260 , 0 30 113 196 280 , 0 30 60 90 120 } -grid_reset 16.8 +} -cleanup { + grid_reset 16.8 +} -result {0 30 130 230 280 , 0 30 130 230 260 , 0 30 113 196 280 , 0 30 60 90 120 } -test grid-16.9 {layout uniform} { +test grid-16.9 {layout uniform} -body { frame .f1 -width 75 -height 50 frame .f2 -width 60 -height 25 frame .f3 -width 95 -height 75 @@ -1566,10 +1682,11 @@ test grid-16.9 {layout uniform} { update list [grid bbox . 0 0] [grid bbox . 0 1] [grid bbox . 0 2] \ [grid bbox . 0 3] [grid bbox . 0 4] -} {{0 0 135 75} {0 75 135 100} {0 175 135 75} {0 250 135 100} {0 350 135 40}} -grid_reset 16.9 +} -cleanup { + grid_reset 16.9 +} -result {{0 0 135 75} {0 75 135 100} {0 175 135 75} {0 250 135 100} {0 350 135 40}} -test grid-16.10 {layout uniform} { +test grid-16.10 {layout uniform} -body { grid [frame .f1 -width 75 -height 50] -row 0 -column 0 grid [frame .f2 -width 60 -height 30] -row 1 -column 2 grid [frame .f3 -width 95 -height 90] -row 2 -column 1 @@ -1587,10 +1704,11 @@ test grid-16.10 {layout uniform} { update list [grid bbox . 0 0] [grid bbox . 2 1] [grid bbox . 1 2] \ [grid bbox . 4 3] [grid bbox . 3 4] -} {{0 0 75 60} {170 60 150 30} {75 90 95 90} {390 180 140 100} {320 280 70 45}} -grid_reset 16.10 +} -cleanup { + grid_reset 16.10 +} -result {{0 0 75 60} {170 60 150 30} {75 90 95 90} {390 180 140 100} {320 280 70 45}} -test grid-16.11 {layout uniform (shrink)} { +test grid-16.11 {layout uniform (shrink)} -body { frame .f1 -width 75 -height 50 frame .f2 -width 100 -height 95 grid .f1 .f2 -sticky news @@ -1603,10 +1721,11 @@ test grid-16.11 {layout uniform (shrink)} { . configure -width 150 -height 95 update lappend res [grid bbox . 0 0] [grid bbox . 1 0] -} {{0 0 100 95} {100 0 100 95} {0 0 50 95} {50 0 100 95}} -grid_reset 16.11 +} -cleanup { + grid_reset 16.11 +} -result {{0 0 100 95} {100 0 100 95} {0 0 50 95} {50 0 100 95}} -test grid-16.12 {layout uniform (grow)} { +test grid-16.12 {layout uniform (grow)} -body { frame .f1 -width 40 -height 50 frame .f2 -width 50 -height 95 frame .f3 -width 60 -height 50 @@ -1627,11 +1746,12 @@ test grid-16.12 {layout uniform (grow)} { update lappend res [grid bbox . 0 0] [grid bbox . 1 0] lappend res [grid bbox . 2 0] [grid bbox . 3 0] -} [list {0 0 50 95} {50 0 50 95} {100 0 100 95} {200 0 70 95} \ +} -cleanup { + grid_reset 16.12 +} -result [list {0 0 50 95} {50 0 50 95} {100 0 100 95} {200 0 70 95} \ {0 0 70 95} {70 0 50 95} {120 0 140 95} {260 0 90 95}] -grid_reset 16.12 -test grid-16.13 {layout span} { +test grid-16.13 {layout span} -body { frame .f1 -width 24 -height 20 frame .f2 -width 38 -height 20 frame .f3 -width 150 -height 20 @@ -1654,11 +1774,12 @@ test grid-16.13 {layout span} { set res # The last result below should ideally be 8 8 8 126 but the current # implementation is not exact enough. -} [list [list 0 112 0 38 0] [list 0 0 112 38 0] [list 14 42 56 38 0] \ +} -cleanup { + grid_reset 16.13 +} -result [list [list 0 112 0 38 0] [list 0 0 112 38 0] [list 14 42 56 38 0] \ [list 18 38 18 76 0] [list 7 8 9 126 0]] -grid_reset 16.13 -test grid-16.14 {layout span} { +test grid-16.14 {layout span} -body { frame .f1 -width 110 -height 20 frame .f2 -width 38 -height 20 frame .f3 -width 150 -height 20 @@ -1679,11 +1800,12 @@ test grid-16.14 {layout span} { lappend res $res2 } set res -} [list [list 0 112 0 38 0] [list 0 0 112 38 0] [list 14 42 56 38 0] \ +} -cleanup { + grid_reset 16.14 +} -result [list [list 0 112 0 38 0] [list 0 0 112 38 0] [list 14 42 56 38 0] \ [list 27 55 28 40 0] [list 36 37 37 40 0]] -grid_reset 16.14 -test grid-16.15 {layout span} { +test grid-16.15 {layout span} -body { frame .f1 -width 24 -height 20 frame .f2 -width 38 -height 20 frame .f3 -width 150 -height 20 @@ -1704,11 +1826,12 @@ test grid-16.15 {layout span} { lappend res $res2 } set res -} [list [list 0 112 0 38 0] [list 0 0 112 38 0] [list 0 0 112 38 0] \ +} -cleanup { + grid_reset 16.15 +} -result [list [list 0 112 0 38 0] [list 0 0 112 38 0] [list 0 0 112 38 0] \ [list 0 37 37 76 0] [list 0 12 12 126 0]] -grid_reset 16.15 -test grid-16.16 {layout span} { +test grid-16.16 {layout span} -body { frame .f1 -width 64 -height 20 frame .f2 -width 38 -height 20 frame .f3 -width 150 -height 20 @@ -1733,11 +1856,12 @@ test grid-16.16 {layout span} { lappend res $res2 } set res -} [list [list 30 34 43 43 0] [list 30 34 48 38 0] [list 22 42 48 38 0] \ +} -cleanup { + grid_reset 16.16 +} -result [list [list 30 34 43 43 0] [list 30 34 48 38 0] [list 22 42 48 38 0] \ [list 25 39 29 57 0] [list 30 34 22 64 0]] -grid_reset 16.16 -test grid-16.17 {layout weights (shrinking at minsize)} { +test grid-16.17 {layout weights (shrinking at minsize)} -body { foreach i {0 1 2 3} { frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge grid .$i -row $i -column $i -sticky nswe @@ -1757,10 +1881,11 @@ test grid-16.17 {layout weights (shrinking at minsize)} { lappend a [winfo width .$i]-[winfo height .$i]-[winfo ismapped .$i] } set a -} {25-25-1 25-25-1 100-75-1 100-75-1 25-25-0 25-25-0 100-75-1 100-75-1} -grid_reset 16.17 +} -cleanup { + grid_reset 16.17 +} -result {25-25-1 25-25-1 100-75-1 100-75-1 25-25-0 25-25-0 100-75-1 100-75-1} -test grid-16.18 {layout span} { +test grid-16.18 {layout span} -body { frame .f1 -width 30 -height 20 frame .f2 -width 166 -height 20 frame .f3 -width 39 -height 20 @@ -1783,10 +1908,12 @@ test grid-16.18 {layout span} { lappend res $res2 } set res -} [list [list 137 29 10] [list 30 136 10] [list 98 68 10]] -grid_reset 16.18 +} -cleanup { + grid_reset 16.18 +} -result [list [list 137 29 10] [list 30 136 10] [list 98 68 10]] + -test grid-17.1 {forget and pending idle handlers} { +test grid-17.1 {forget and pending idle handlers} -body { # This test is intended to detect a crash caused by a failure to remove # pending idle handlers when grid forget is invoked. @@ -1807,9 +1934,10 @@ test grid-17.1 {forget and pending idle handlers} { grid .t.f.l destroy .t set result ok -} ok +} -result ok -test grid-18.1 {test respect for internalborder} { + +test grid-18.1 {test respect for internalborder} -body { toplevel .pack wm geometry .pack 200x200 frame .pack.l -width 15 -height 10 @@ -1826,8 +1954,8 @@ test grid-18.1 {test respect for internalborder} { lappend res [winfo geometry .pack.lf.f] destroy .pack set res -} {196x188+2+10 177x186+5+7} -test grid-18.2 {test support for minreqsize} { +} -result {196x188+2+10 177x186+5+7} +test grid-18.2 {test support for minreqsize} -body { toplevel .pack wm geometry .pack {} frame .pack.l -width 150 -height 100 @@ -1842,9 +1970,10 @@ test grid-18.2 {test support for minreqsize} { lappend res [winfo geometry .pack.lf] destroy .pack set res -} {162x127+0+0 172x112+0+0} +} -result {162x127+0+0 172x112+0+0} + -test grid-19.1 {uniform realloc} { +test grid-19.1 {uniform realloc} -body { # Use a lot of uniform groups to test the reallocation mechanism for {set t 0} {$t < 100} {incr t 2} { frame .fa$t -width 5 -height 20 @@ -1854,55 +1983,65 @@ test grid-19.1 {uniform realloc} { } update grid bbox . -} {0 0 600 20} -grid_reset 19.1 +} -cleanup { + grid_reset 19.1 +} -result {0 0 600 20} -test grid-20.1 {recalculate size after removal (destroy)} { + +test grid-20.1 {recalculate size after removal (destroy)} -body { label .l1 -text l1 grid .l1 -row 2 -column 2 destroy .l1 label .l2 -text l2 grid .l2 grid size . -} {1 1} -grid_reset 20.1 +} -cleanup { + grid_reset 20.1 +} -result {1 1} -test grid-20.2 {recalculate size after removal (forget)} { +test grid-20.2 {recalculate size after removal (forget)} -body { label .l1 -text l1 grid .l1 -row 2 -column 2 grid forget .l1 label .l2 -text l2 grid .l2 grid size . -} {1 1} -grid_reset 20.2 - -test grid-21.1 {anchor} { - list [catch {grid anchor . 1 xxx} msg] $msg -} {1 {wrong # args: should be "grid anchor window ?anchor?"}} -grid_reset 21.1 - -test grid-21.2 {anchor} { - list [catch {grid anchor .} msg] $msg -} {0 nw} -grid_reset 21.2 - -test grid-21.3 {anchor} { - list [catch {grid anchor . se;grid anchor .} msg] $msg -} {0 se} -grid_reset 21.3 - -test grid-21.4 {anchor} { - list [catch {grid anchor .x} msg] $msg -} {1 {bad window path name ".x"}} -grid_reset 21.4 - -test grid-21.5 {anchor} { - list [catch {grid anchor . x} msg] $msg -} {1 {bad anchor "x": must be n, ne, e, se, s, sw, w, nw, or center}} -grid_reset 21.5 - -test grid-21.6 {anchor} { +} -cleanup { + grid_reset 20.2 +} -result {1 1} + + +test grid-21.1 {anchor} -body { + grid anchor . 1 xxx +} -cleanup { + grid_reset 21.1 +} -returnCodes error -result {wrong # args: should be "grid anchor window ?anchor?"} + +test grid-21.2 {anchor} -body { + grid anchor . +} -cleanup { + grid_reset 21.2 +} -result {nw} + +test grid-21.3 {anchor} -body { + grid anchor . se;grid anchor . +} -cleanup { + grid_reset 21.3 +} -result {se} + +test grid-21.4 {anchor} -body { + grid anchor .x +} -cleanup { + grid_reset 21.4 +} -returnCodes error -result {bad window path name ".x"} + +test grid-21.5 {anchor} -body { + grid anchor . x +} -cleanup { + grid_reset 21.5 +} -returnCodes error -result {bad anchor "x": must be n, ne, e, se, s, sw, w, nw, or center} + +test grid-21.6 {anchor} -body { foreach i {0 1 2} { frame .$i -bg gray -width 75 -height 50 -bd 2 -relief ridge grid .$i -row $i -column $i -sticky nswe @@ -1917,12 +2056,13 @@ test grid-21.6 {anchor} { lappend res [grid bbox .] } set res -} [list {37 0 225 150} {75 0 225 150} {75 50 225 150} {75 100 225 150} \ +} -cleanup { + grid_reset 21.6 +} -result [list {37 0 225 150} {75 0 225 150} {75 50 225 150} {75 100 225 150} \ {37 100 225 150} {0 100 225 150} {0 50 225 150} {0 0 225 150} \ {37 50 225 150}] -grid_reset 21.6 -test grid-21.7 {anchor} { +test grid-21.7 {anchor} -body { # Test with a non-symmetric internal border. # This only tests vertically, there is currently no way to get # it assymetric horizontally. @@ -1947,11 +2087,15 @@ test grid-21.7 {anchor} { } pack propagate . 1 ; wm geometry . {} set res -} [list {37 20 225 150} {75 20 225 150} {75 60 225 150} {75 100 225 150} \ +} -cleanup { + grid_reset 21.7 +} -result [list {37 20 225 150} {75 20 225 150} {75 60 225 150} {75 100 225 150} \ {37 100 225 150} {0 100 225 150} {0 60 225 150} {0 20 225 150} \ {37 60 225 150}] -grid_reset 21.7 # cleanup cleanupTests return + + + diff --git a/tests/safe.test b/tests/safe.test index d2406ab..7ec859c 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -6,11 +6,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: safe.test,v 1.18 2007/12/13 15:27:54 dgp Exp $ +# RCS: @(#) $Id: safe.test,v 1.19 2008/08/16 23:52:34 aniap Exp $ -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test ## NOTE: Any time tests fail here with an error like: @@ -43,99 +44,117 @@ if {[string equal $tcl_platform(platform) "windows"]} { set saveAutoPath $::auto_path set auto_path [list [info library] $::tk_library] -test safe-1.1 {Safe Tk loading into an interpreter} { - catch {safe::interpDelete a} +test safe-1.1 {Safe Tk loading into an interpreter} -setup { + catch {safe::interpDelete a} +} -body { safe::loadTk [safe::interpCreate a] safe::interpDelete a set x {} - set x -} "" -test safe-1.2 {Safe Tk loading into an interpreter} { - catch {safe::interpDelete a} + return $x +} -result {} +test safe-1.2 {Safe Tk loading into an interpreter} -setup { + catch {safe::interpDelete a} +} -body { safe::interpCreate a safe::loadTk a - set l [lsort [interp hidden a]] + lsort [interp hidden a] +} -cleanup { safe::interpDelete a - set l -} $hidden_cmds -test safe-1.3 {Safe Tk loading into an interpreter} -body { - catch {safe::interpDelete a} +} -result $hidden_cmds +test safe-1.3 {Safe Tk loading into an interpreter} -setup { + catch {safe::interpDelete a} +} -body { safe::interpCreate a safe::loadTk a - set l [lsort [interp aliases a]] + lsort [interp aliases a] +} -cleanup { safe::interpDelete a - set l } -match glob -result {*encoding*exit*file*load*source*} -test safe-2.1 {Unsafe commands not available} { - catch {safe::interpDelete a} + +test safe-2.1 {Unsafe commands not available} -setup { + catch {safe::interpDelete a} +} -body { safe::interpCreate a safe::loadTk a set status broken if {[catch {interp eval a {toplevel .t}} msg]} { set status ok } + return $status +} -cleanup { safe::interpDelete a - set status -} ok -test safe-2.2 {Unsafe commands not available} { - catch {safe::interpDelete a} +} -result ok +test safe-2.2 {Unsafe commands not available} -setup { + catch {safe::interpDelete a} +} -body { safe::interpCreate a safe::loadTk a set status broken if {[catch {interp eval a {menu .m}} msg]} { set status ok } + return $status +} -cleanup { safe::interpDelete a - set status -} ok -test safe-2.3 {Unsafe subcommands not available} { - catch {safe::interpDelete a} +} -result ok +test safe-2.3 {Unsafe subcommands not available} -setup { + catch {safe::interpDelete a} +} -body { safe::interpCreate a safe::loadTk a set status broken if {[catch {interp eval a {tk appname}} msg]} { set status ok } - safe::interpDelete a list $status $msg -} {ok {appname not accessible in a safe interpreter}} -test safe-2.4 {Unsafe subcommands not available} { - catch {safe::interpDelete a} +} -cleanup { + safe::interpDelete a +} -result {ok {appname not accessible in a safe interpreter}} +test safe-2.4 {Unsafe subcommands not available} -setup { + catch {safe::interpDelete a} +} -body { safe::interpCreate a safe::loadTk a set status broken if {[catch {interp eval a {tk scaling}} msg]} { set status ok } - safe::interpDelete a list $status $msg -} {ok {scaling not accessible in a safe interpreter}} +} -cleanup { + safe::interpDelete a +} -result {ok {scaling not accessible in a safe interpreter}} + -test safe-3.1 {Unsafe commands are available hidden} { - catch {safe::interpDelete a} +test safe-3.1 {Unsafe commands are available hidden} -setup { + catch {safe::interpDelete a} +} -body { safe::interpCreate a safe::loadTk a set status ok if {[catch {interp invokehidden a toplevel .t} msg]} { set status broken } + return $status +} -cleanup { safe::interpDelete a - set status -} ok -test safe-3.2 {Unsafe commands are available hidden} { - catch {safe::interpDelete a} +} -result ok +test safe-3.2 {Unsafe commands are available hidden} -setup { + catch {safe::interpDelete a} +} -body { safe::interpCreate a safe::loadTk a set status ok if {[catch {interp invokehidden a menu .m} msg]} { set status broken } + return $status +} -cleanup { safe::interpDelete a - set status -} ok +} -result ok -test safe-4.1 {testing loadTk} { + +test safe-4.1 {testing loadTk} -body { # no error shall occur, the user will # eventually see a new toplevel set i [safe::loadTk [safe::interpCreate]] @@ -144,27 +163,28 @@ test safe-4.1 {testing loadTk} { # to position the window (if the wm does not do it automatically) # and thus make the test suite not runable non interactively safe::interpDelete $i -} {} +} -result {} -test safe-4.2 {testing loadTk -use} { +test safe-4.2 {testing loadTk -use} -body { set w .safeTkFrame - catch {destroy $w} + destroy $w frame $w -container 1; pack .safeTkFrame set i [safe::loadTk [safe::interpCreate] -use [winfo id $w]] interp eval $i {button .b -text "hello world!"; pack .b} safe::interpDelete $i destroy $w -} {} +} -result {} + -test safe-5.1 {loading Tk in safe interps without master's clearance} { +test safe-5.1 {loading Tk in safe interps without master's clearance} -body { set i [safe::interpCreate] - catch {interp eval $i {load {} Tk}} msg + interp eval $i {load {} Tk} +} -cleanup { safe::interpDelete $i - set msg -} {not allowed to start Tk by master's safe::TkInit} +} -returnCodes error -result {not allowed to start Tk by master's safe::TkInit} -test safe-5.2 {multi-level Tk loading with clearance} { +test safe-5.2 {multi-level Tk loading with clearance} -body { # No error shall occur in that test and no window # shall remain at the end. set i [safe::interpCreate] @@ -172,47 +192,52 @@ test safe-5.2 {multi-level Tk loading with clearance} { set j [safe::interpCreate $j] safe::loadTk $j interp eval $j { - button .b -text Ok -command {destroy .} - pack .b -# tkwait window . ; # for interactive testing/debugging + button .b -text Ok -command {destroy .} + pack .b +# tkwait window . ; # for interactive testing/debugging } +} -cleanup { safe::interpDelete $j safe::interpDelete $i -} {} +} -result {} -test safe-6.1 {loadTk -use windowPath} { + +test safe-6.1 {loadTk -use windowPath} -body { set w .safeTkFrame - catch {destroy $w} + destroy $w frame $w -container 1; pack .safeTkFrame set i [safe::loadTk [safe::interpCreate] -use $w] interp eval $i {button .b -text "hello world!"; pack .b} safe::interpDelete $i destroy $w -} {} +} -result {} -test safe-6.2 {loadTk -use windowPath, conflicting -display} { +test safe-6.2 {loadTk -use windowPath, conflicting -display} -body { set w .safeTkFrame - catch {destroy $w} + destroy $w frame $w -container 1; pack .safeTkFrame set i [safe::interpCreate] catch {safe::loadTk $i -use $w -display :23.56} msg + string range $msg 0 36 +} -cleanup { safe::interpDelete $i destroy $w - string range $msg 0 36 -} {conflicting -display :23.56 and -use } +} -result {conflicting -display :23.56 and -use } -test safe-7.1 {canvas printing} { +test safe-7.1 {canvas printing} -body { set i [safe::loadTk [safe::interpCreate]] - set r [catch {interp eval $i {canvas .c; .c postscript}}] + interp eval $i {canvas .c; .c postscript} +} -cleanup { safe::interpDelete $i - set r -} 0 +} -returnCodes ok -match glob -result * # cleanup set ::auto_path $saveAutoPath unset hidden_cmds cleanupTests return + + diff --git a/tests/tk.test b/tests/tk.test index e2e0e7e..0527be0 100644 --- a/tests/tk.test +++ b/tests/tk.test @@ -5,137 +5,155 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2002 ActiveState Corporation. # -# RCS: @(#) $Id: tk.test,v 1.14 2005/06/01 15:48:50 rmax Exp $ +# RCS: @(#) $Id: tk.test,v 1.15 2008/08/16 23:52:34 aniap Exp $ -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test -test tk-1.1 {tk command: general} \ - -body {tk} -returnCodes 1 \ - -result {wrong # args: should be "tk option ?arg?"} -test tk-1.2 {tk command: general} \ - -body {tk xyz} -returnCodes 1 \ - -result {bad option "xyz": must be appname, caret, scaling, useinputmethods, windowingsystem, or inactive} +test tk-1.1 {tk command: general} -body { + tk +} -returnCodes error -result {wrong # args: should be "tk option ?arg?"} +test tk-1.2 {tk command: general} -body { + tk xyz +} -returnCodes error -result {bad option "xyz": must be appname, caret, scaling, useinputmethods, windowingsystem, or inactive} + +# Value stored to restore default settings after 2.* tests set appname [tk appname] -test tk-2.1 {tk command: appname} { - list [catch {tk appname xyz abc} msg] $msg -} {1 {wrong # args: should be "tk appname ?newName?"}} -test tk-2.2 {tk command: appname} { +test tk-2.1 {tk command: appname} -body { + tk appname xyz abc +} -returnCodes error -result {wrong # args: should be "tk appname ?newName?"} +test tk-2.2 {tk command: appname} -body { tk appname foobazgarply -} {foobazgarply} -test tk-2.3 {tk command: appname} unix { +} -result {foobazgarply} +test tk-2.3 {tk command: appname} -constraints unix -body { tk appname bazfoogarply expr {[lsearch -exact [winfo interps] [tk appname]] >= 0} -} {1} -test tk-2.4 {tk command: appname} { - tk appname $appname -} $appname +} -result {1} +test tk-2.4 {tk command: appname} -body { + tk appname [tk appname] +} -result [tk appname] tk appname $appname + +# Value stored to restore default settings after 3.* tests set scaling [tk scaling] -test tk-3.1 {tk command: scaling} { - list [catch {tk scaling -displayof} msg] $msg -} {1 {value for "-displayof" missing}} -test tk-3.2 {tk command: scaling: get current} { +test tk-3.1 {tk command: scaling} -body { + tk scaling -displayof +} -returnCodes error -result {value for "-displayof" missing} +test tk-3.2 {tk command: scaling: get current} -body { tk scaling 1 format %.2g [tk scaling] -} 1 -test tk-3.3 {tk command: scaling: get current} { +} -result 1 +test tk-3.3 {tk command: scaling: get current} -body { tk scaling -displayof . 1.25 format %.3g [tk scaling] -} 1.25 -test tk-3.4 {tk command: scaling: set new} { - list [catch {tk scaling xyz} msg] $msg -} {1 {expected floating-point number but got "xyz"}} -test tk-3.5 {tk command: scaling: set new} { - list [catch {tk scaling -displayof . xyz} msg] $msg -} {1 {expected floating-point number but got "xyz"}} -test tk-3.6 {tk command: scaling: set new} { +} -result 1.25 +test tk-3.4 {tk command: scaling: set new} -body { + tk scaling xyz +} -returnCodes error -result {expected floating-point number but got "xyz"} +test tk-3.5 {tk command: scaling: set new} -body { + tk scaling -displayof . xyz +} -returnCodes error -result {expected floating-point number but got "xyz"} +test tk-3.6 {tk command: scaling: set new} -body { tk scaling 1 format %.2g [tk scaling] -} 1 -test tk-3.7 {tk command: scaling: set new} { +} -result 1 +test tk-3.7 {tk command: scaling: set new} -body { tk scaling -displayof . 1.25 format %.3g [tk scaling] -} 1.25 -test tk-3.8 {tk command: scaling: negative} { +} -result 1.25 +test tk-3.8 {tk command: scaling: negative} -body { tk scaling -1 expr {[tk scaling] > 0} -} {1} -test tk-3.9 {tk command: scaling: too big} { +} -result {1} +test tk-3.9 {tk command: scaling: too big} -body { tk scaling 1000000 expr {[tk scaling] < 10000} -} {1} -test tk-3.10 {tk command: scaling: widthmm} { +} -result {1} +test tk-3.10 {tk command: scaling: widthmm} -body { tk scaling 1.25 - expr {int((25.4*[winfo screenwidth .])/(72*1.25)+0.5)-[winfo screenmmwidth .]} -} {0} -test tk-3.11 {tk command: scaling: heightmm} { + expr {int((25.4*[winfo screenwidth .])/(72*1.25) + 0.5) \ + - [winfo screenmmwidth .]} +} -result {0} +test tk-3.11 {tk command: scaling: heightmm} -body { tk scaling 1.25 - expr {int((25.4*[winfo screenheight .])/(72*1.25)+0.5)-[winfo screenmmheight .]} -} {0} + expr {int((25.4*[winfo screenheight .])/(72*1.25) + 0.5) \ + - [winfo screenmmheight .]} +} -result {0} tk scaling $scaling + +# Value stored to restore default settings after 4.* tests set useim [tk useinputmethods] -test tk-4.1 {tk command: useinputmethods} { - list [catch {tk useinputmethods -displayof} msg] $msg -} {1 {value for "-displayof" missing}} -test tk-4.2 {tk command: useinputmethods: get current} { +test tk-4.1 {tk command: useinputmethods} -body { + tk useinputmethods -displayof +} -returnCodes error -result {value for "-displayof" missing} +test tk-4.2 {tk command: useinputmethods: get current} -body { + tk useinputmethods no +} -cleanup { + tk useinputmethods $useim +} -result 0 +test tk-4.3 {tk command: useinputmethods: get current} -body { tk useinputmethods no -} 0 -test tk-4.3 {tk command: useinputmethods: get current} { tk useinputmethods -displayof . -} 0 -test tk-4.4 {tk command: useinputmethods: set new} { - list [catch {tk useinputmethods xyz} msg] $msg -} {1 {expected boolean value but got "xyz"}} -test tk-4.5 {tk command: useinputmethods: set new} { - list [catch {tk useinputmethods -displayof . xyz} msg] $msg -} {1 {expected boolean value but got "xyz"}} -test tk-4.6 {tk command: useinputmethods: set new} unix { +} -cleanup { + tk useinputmethods $useim +} -result 0 +test tk-4.4 {tk command: useinputmethods: set new} -body { + tk useinputmethods xyz +} -returnCodes error -result {expected boolean value but got "xyz"} +test tk-4.5 {tk command: useinputmethods: set new} -body { + tk useinputmethods -displayof . xyz +} -returnCodes error -result {expected boolean value but got "xyz"} +test tk-4.6 {tk command: useinputmethods: set new} -body { # This isn't really a test, but more of a check... # The answer is what was given, because we may be on a Unix # system that doesn't have the XIM stuff if {[tk useinputmethods 1] == 0} { - puts "this wish doesn't have XIM (X Input Methods) support" + puts "this wish doesn't have XIM (X Input Methods) support" } - set useim -} $useim -test tk-4.7 {tk command: useinputmethods: set new} win { + + return $useim +} -result $useim +test tk-4.7 {tk command: useinputmethods: set new} -constraints win -body { # Mac and Windows don't have X Input Methods, so this should # always return 0 tk useinputmethods 1 -} 0 -tk useinputmethods $useim - -test tk-5.1 {tk caret} { - list [catch {tk caret} msg] $msg -} {1 {wrong # args: should be "tk caret window ?-x x? ?-y y? ?-height height?"}} -test tk-5.2 {tk caret} { - list [catch {tk caret bogus} msg] $msg -} {1 {bad window path name "bogus"}} -test tk-5.3 {tk caret} { - list [catch {tk caret . -foo} msg] $msg -} {1 {bad caret option "-foo": must be -x, -y, or -height}} -test tk-5.4 {tk caret} { - list [catch {tk caret . -x 0 -y} msg] $msg -} {1 {wrong # args: should be "tk caret window ?-x x? ?-y y? ?-height height?"}} -test tk-5.5 {tk caret} { - list [catch {tk caret . -x 10 -y 11 -h 12; tk caret .} msg] $msg -} {0 {-height 12 -x 10 -y 11}} -test tk-5.6 {tk caret} { - list [catch {tk caret . -x 20 -y 25 -h 30; tk caret . -hei} msg] $msg -} {0 30} +} -cleanup { + tk useinputmethods $useim +} -result 0 + + +test tk-5.1 {tk caret} -body { + tk caret +} -returnCodes error -result {wrong # args: should be "tk caret window ?-x x? ?-y y? ?-height height?"} +test tk-5.2 {tk caret} -body { + tk caret bogus +} -returnCodes error -result {bad window path name "bogus"} +test tk-5.3 {tk caret} -body { + tk caret . -foo +} -returnCodes error -result {bad caret option "-foo": must be -x, -y, or -height} +test tk-5.4 {tk caret} -body { + tk caret . -x 0 -y +} -returnCodes error -result {wrong # args: should be "tk caret window ?-x x? ?-y y? ?-height height?"} +test tk-5.5 {tk caret} -body { + tk caret . -x 10 -y 11 -h 12; tk caret . +} -result {-height 12 -x 10 -y 11} +test tk-5.6 {tk caret} -body { + tk caret . -x 20 -y 25 -h 30; tk caret . -hei +} -result {30} + # tk inactive test tk-6.1 {tk inactive} -body { string is integer [tk inactive] } -result 1 test tk-6.2 {tk inactive reset} -body { - catch {tk inactive reset} -} -result 0 + tk inactive reset +} -returnCodes ok -match glob -result * test tk-6.3 {tk inactive wrong argument} -body { tk inactive foo } -returnCodes 1 -result {bad option "foo": must be reset} @@ -150,16 +168,24 @@ test tk-6.5 {tk inactive} -body { expr {$i == -1 || ( $i > 90 && $i < 200 )} } -result 1 -# tk inactive in safe interpreters -safe::interpCreate foo -safe::loadTk foo + test tk-7.1 {tk inactive in a safe interpreter} -body { +# tk inactive in safe interpreters + safe::interpCreate foo + safe::loadTk foo foo eval {tk inactive} +} -cleanup { + ::safe::interpDelete foo } -result -1 test tk-7.2 {tk inactive reset in a safe interpreter} -body { +# tk inactive in safe interpreters + safe::interpCreate foo + safe::loadTk foo foo eval {tk inactive reset} +} -cleanup { + ::safe::interpDelete foo } -returnCodes 1 -result {resetting the user inactivity timer is not allowed in a safe interpreter} -::safe::interpDelete foo + # cleanup cleanupTests diff --git a/tests/util.test b/tests/util.test index 212ea8a..2741962 100644 --- a/tests/util.test +++ b/tests/util.test @@ -6,63 +6,65 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: util.test,v 1.7 2004/05/23 17:34:49 dkf Exp $ +# RCS: @(#) $Id: util.test,v 1.8 2008/08/16 23:52:34 aniap Exp $ -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test listbox .l -width 20 -height 5 -relief sunken -bd 2 pack .l .l insert 0 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 update -test util-1.1 {Tk_GetScrollInfo procedure} { - list [catch {.l yview moveto a b} msg] $msg -} {1 {wrong # args: should be ".l yview moveto fraction"}} -test util-1.2 {Tk_GetScrollInfo procedure} { - list [catch {.l yview moveto xyz} msg] $msg -} {1 {expected floating-point number but got "xyz"}} -test util-1.3 {Tk_GetScrollInfo procedure} { +test util-1.1 {Tk_GetScrollInfo procedure} -body { + .l yview moveto a b +} -returnCodes error -result {wrong # args: should be ".l yview moveto fraction"} +test util-1.2 {Tk_GetScrollInfo procedure} -body { + .l yview moveto xyz +} -returnCodes error -result {expected floating-point number but got "xyz"} +test util-1.3 {Tk_GetScrollInfo procedure} -body { .l yview 0 .l yview moveto .5 .l yview -} {0.5 0.75} -test util-1.4 {Tk_GetScrollInfo procedure} { - list [catch {.l yview scroll a} msg] $msg -} {1 {wrong # args: should be ".l yview scroll number units|pages"}} -test util-1.5 {Tk_GetScrollInfo procedure} { - list [catch {.l yview scroll a b c} msg] $msg -} {1 {wrong # args: should be ".l yview scroll number units|pages"}} -test util-1.6 {Tk_GetScrollInfo procedure} { - list [catch {.l yview scroll xyz units} msg] $msg -} {1 {expected integer but got "xyz"}} -test util-1.7 {Tk_GetScrollInfo procedure} { +} -result {0.5 0.75} +test util-1.4 {Tk_GetScrollInfo procedure} -body { + .l yview scroll a +} -returnCodes error -result {wrong # args: should be ".l yview scroll number units|pages"} +test util-1.5 {Tk_GetScrollInfo procedure} -body { + .l yview scroll a b c +} -returnCodes error -result {wrong # args: should be ".l yview scroll number units|pages"} +test util-1.6 {Tk_GetScrollInfo procedure} -body { + .l yview scroll xyz units +} -returnCodes error -result {expected integer but got "xyz"} +test util-1.7 {Tk_GetScrollInfo procedure} -body { .l yview 0 .l yview scroll 2 pages .l nearest 0 -} {6} -test util-1.8 {Tk_GetScrollInfo procedure} { +} -result {6} +test util-1.8 {Tk_GetScrollInfo procedure} -body { .l yview 15 .l yview scroll -2 pages .l nearest 0 -} {9} -test util-1.9 {Tk_GetScrollInfo procedure} { +} -result {9} +test util-1.9 {Tk_GetScrollInfo procedure} -body { .l yview 0 .l yview scroll 2 units .l nearest 0 -} {2} -test util-1.10 {Tk_GetScrollInfo procedure} { +} -result {2} +test util-1.10 {Tk_GetScrollInfo procedure} -body { .l yview 15 .l yview scroll -2 units .l nearest 0 -} {13} -test util-1.11 {Tk_GetScrollInfo procedure} { - list [catch {.l yview scroll 3 zips} msg] $msg -} {1 {bad argument "zips": must be units or pages}} -test util-1.12 {Tk_GetScrollInfo procedure} { - list [catch {.l yview dropdead 3 times} msg] $msg -} {1 {unknown option "dropdead": must be moveto or scroll}} +} -result {13} +test util-1.11 {Tk_GetScrollInfo procedure} -body { + .l yview scroll 3 zips +} -returnCodes error -result {bad argument "zips": must be units or pages} +test util-1.12 {Tk_GetScrollInfo procedure} -body { + .l yview dropdead 3 times +} -returnCodes error -result {unknown option "dropdead": must be moveto or scroll} # cleanup cleanupTests return + |