diff options
| -rw-r--r-- | tests/cmds.test | 52 | ||||
| -rw-r--r-- | tests/dialog.test | 77 | ||||
| -rw-r--r-- | tests/get.test | 134 |
3 files changed, 175 insertions, 88 deletions
diff --git a/tests/cmds.test b/tests/cmds.test index 0d989a1..f8fa690 100644 --- a/tests/cmds.test +++ b/tests/cmds.test @@ -5,40 +5,58 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: cmds.test,v 1.6 2004/05/23 17:34:48 dkf Exp $ +# RCS: @(#) $Id: cmds.test,v 1.7 2008/08/03 15:28:53 aniap Exp $ -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test update -test cmds-1.1 {tkwait visibility, argument errors} { - list [catch {tkwait visibility} msg] $msg -} {1 {wrong # args: should be "tkwait variable|visibility|window name"}} -test cmds-1.2 {tkwait visibility, argument errors} { - list [catch {tkwait visibility foo bar} msg] $msg -} {1 {wrong # args: should be "tkwait variable|visibility|window name"}} -test cmds-1.3 {tkwait visibility, argument errors} { - list [catch {tkwait visibility bad_window} msg] $msg -} {1 {bad window path name "bad_window"}} -test cmds-1.4 {tkwait visibility, waiting for window to be mapped} { +test cmds-1.1 {tkwait visibility, argument errors} -body { + tkwait visibility +} -returnCodes {error} -result {wrong # args: should be "tkwait variable|visibility|window name"} +test cmds-1.2 {tkwait visibility, argument errors} -body { + tkwait visibility foo bar +} -returnCodes {error} -result {wrong # args: should be "tkwait variable|visibility|window name"} +test cmds-1.3 {tkwait visibility, argument errors} -body { + tkwait visibility bad_window +} -returnCodes {error} -result {bad window path name "bad_window"} +test cmds-1.4 {tkwait visibility, waiting for window to be mapped} -setup { button .b -text "Test" set x init +} -body { after 100 {set x delay; place .b -x 0 -y 0} tkwait visibility .b + return $x +} -cleanup { destroy .b - set x -} {delay} -test cmds-1.5 {tkwait visibility, window gets deleted} { +} -result {delay} +test cmds-1.5 {tkwait visibility, window gets deleted} -setup { frame .f button .f.b -text "Test" pack .f.b set x init +} -body { after 100 {set x deleted; destroy .f} - list [catch {tkwait visibility .f.b} msg] $msg $x -} {1 {window ".f.b" was deleted before its visibility changed} deleted} + tkwait visibility .f.b +} -returnCodes {error} -result {window ".f.b" was deleted before its visibility changed} +test cmds-1.6 {tkwait visibility, window gets deleted} -setup { + frame .f + button .f.b -text "Test" + pack .f.b + set x init +} -body { + after 100 {set x deleted; destroy .f} + catch {tkwait visibility .f.b} + return $x +} -cleanup { + destroy .f +} -result {deleted} + # cleanup cleanupTests return + diff --git a/tests/dialog.test b/tests/dialog.test index 519ca4f..bd8c944 100644 --- a/tests/dialog.test +++ b/tests/dialog.test @@ -1,61 +1,70 @@ # This file is a Tcl script to test out Tk's "tk_dialog" command. # It is organized in the standard fashion for Tcl tests. # -# RCS: @(#) $Id: dialog.test,v 1.5 2004/11/01 16:51:21 dgp Exp $ +# RCS: @(#) $Id: dialog.test,v 1.6 2008/08/03 15:28:53 aniap Exp $ # -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test test dialog-1.1 {tk_dialog command} -body { - list [catch {tk_dialog} msg] $msg -} -match glob -result {1 {wrong # args: should be "tk_dialog w title text bitmap default *"}} -test dialog-1.2 {tk_dialog command} { - list [catch {tk_dialog foo foo foo foo foo} msg] $msg -} {1 {bad window path name "foo"}} -test dialog-1.3 {tk_dialog command} { - set res [list [catch {tk_dialog .d foo foo foo foo} msg] $msg] + tk_dialog +} -match glob -returnCodes error -result {wrong # args: should be "tk_dialog w title text bitmap default *"} +test dialog-1.2 {tk_dialog command} -body { + tk_dialog foo foo foo foo foo +} -returnCodes error -result {bad window path name "foo"} +test dialog-1.3 {tk_dialog command} -body { + tk_dialog .d foo foo foo foo +} -cleanup { destroy .d - set res -} {1 {bitmap "foo" not defined}} +} -returnCodes error -result {bitmap "foo" not defined} -proc PressButton {btn} { - if {![winfo ismapped $btn]} { - update - } - event generate $btn <Enter> - event generate $btn <1> -x 5 -y 5 - event generate $btn <ButtonRelease-1> -x 5 -y 5 -} - -proc HitReturn {w} { - event generate $w <Enter> - focus -force $w - event generate $w <KeyPress> -keysym Return -} -test dialog-2.0 {tk_dialog operation} { +test dialog-2.1 {tk_dialog operation} -setup { + proc PressButton {btn} { + if {![winfo ismapped $btn]} { + update + } + event generate $btn <Enter> + event generate $btn <1> -x 5 -y 5 + event generate $btn <ButtonRelease-1> -x 5 -y 5 + } +} -body { set x [after 5000 [list set tk::Priv(button) "no response"]] after 100 PressButton .d.button0 set res [tk_dialog .d foo foo info 0 click] after cancel $x - set res -} {0} -test dialog-2.1 {tk_dialog operation} { + return $res +} -cleanup { + destroy .d +} -result {0} +test dialog-2.2 {tk_dialog operation} -setup { + proc HitReturn {w} { + event generate $w <Enter> + focus -force $w + event generate $w <KeyPress> -keysym Return + } +} -body { set x [after 5000 [list set tk::Priv(button) "no response"]] after 100 HitReturn .d set res [tk_dialog .d foo foo info 1 click default] after cancel $x - set res -} {1} -test dialog-2.2 {tk_dialog operation} { + return $res +} -cleanup { + destroy .d +} -result {1} +test dialog-2.3 {tk_dialog operation} -body { set x [after 5000 [list set tk::Priv(button) "no response"]] after 100 destroy .d set res [tk_dialog .d foo foo info 0 click] after cancel $x - set res -} {-1} + return $res +} -cleanup { + destroy .b +} -result {-1} cleanupTests return + diff --git a/tests/get.test b/tests/get.test index 66c5d1e..dd09f15 100644 --- a/tests/get.test +++ b/tests/get.test @@ -6,75 +6,135 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: get.test,v 1.5 2004/05/23 17:34:48 dkf Exp $ +# RCS: @(#) $Id: get.test,v 1.6 2008/08/03 15:28:53 aniap Exp $ -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test -button .b -test get-1.1 {Tk_GetAnchorFromObj} { +test get-1.1 {Tk_GetAnchorFromObj} -setup { + button .b +} -body { .b configure -anchor n .b cget -anchor -} {n} -test get-1.2 {Tk_GetAnchorFromObj} { +} -cleanup { + destroy .b +} -result {n} +test get-1.2 {Tk_GetAnchorFromObj} -setup { + button .b +} -body { .b configure -anchor ne .b cget -anchor -} {ne} -test get-1.3 {Tk_GetAnchorFromObj} { +} -cleanup { + destroy .b +} -result {ne} +test get-1.3 {Tk_GetAnchorFromObj} -setup { + button .b +} -body { .b configure -anchor e .b cget -anchor -} {e} -test get-1.4 {Tk_GetAnchorFromObj} { +} -cleanup { + destroy .b +} -result {e} +test get-1.4 {Tk_GetAnchorFromObj} -setup { + button .b +} -body { .b configure -anchor se .b cget -anchor -} {se} -test get-1.5 {Tk_GetAnchorFromObj} { +} -cleanup { + destroy .b +} -result {se} +test get-1.5 {Tk_GetAnchorFromObj} -setup { + button .b +} -body { .b configure -anchor s .b cget -anchor -} {s} -test get-1.6 {Tk_GetAnchorFromObj} { +} -cleanup { + destroy .b +} -result {s} +test get-1.6 {Tk_GetAnchorFromObj} -setup { + button .b +} -body { .b configure -anchor sw .b cget -anchor -} {sw} -test get-1.7 {Tk_GetAnchorFromObj} { +} -cleanup { + destroy .b +} -result {sw} +test get-1.7 {Tk_GetAnchorFromObj} -setup { + button .b +} -body { .b configure -anchor w .b cget -anchor -} {w} -test get-1.8 {Tk_GetAnchorFromObj} { +} -cleanup { + destroy .b +} -result {w} +test get-1.8 {Tk_GetAnchorFromObj} -setup { + button .b +} -body { .b configure -anchor nw .b cget -anchor -} {nw} -test get-1.9 {Tk_GetAnchorFromObj} { +} -cleanup { + destroy .b +} -result {nw} +test get-1.9 {Tk_GetAnchorFromObj} -setup { + button .b +} -body { .b configure -anchor n .b cget -anchor -} {n} -test get-1.10 {Tk_GetAnchorFromObj} { +} -cleanup { + destroy .b +} -result {n} +test get-1.10 {Tk_GetAnchorFromObj} -setup { + button .b +} -body { .b configure -anchor center .b cget -anchor -} {center} -test get-1.11 {Tk_GetAnchorFromObj - error} { - list [catch {.b configure -anchor unknown} msg] $msg -} {1 {bad anchor "unknown": must be n, ne, e, se, s, sw, w, nw, or center}} +} -cleanup { + destroy .b +} -result {center} +test get-1.11 {Tk_GetAnchorFromObj - error} -setup { + button .b +} -body { + .b configure -anchor unknown +} -cleanup { + destroy .b +} -returnCodes {error} -result {bad anchor "unknown": must be n, ne, e, se, s, sw, w, nw, or center} -catch {destroy .b} -button .b -test get-2.1 {Tk_GetJustifyFromObj} { + +test get-2.1 {Tk_GetJustifyFromObj} -setup { + button .b +} -body { .b configure -justify left .b cget -justify -} {left} -test get-2.2 {Tk_GetJustifyFromObj} { +} -cleanup { + destroy .b +} -result {left} +test get-2.2 {Tk_GetJustifyFromObj} -setup { + button .b +} -body { .b configure -justify right .b cget -justify -} {right} -test get-2.3 {Tk_GetJustifyFromObj} { +} -cleanup { + destroy .b +} -result {right} +test get-2.3 {Tk_GetJustifyFromObj} -setup { + button .b +} -body { .b configure -justify center .b cget -justify -} {center} -test get-2.4 {Tk_GetJustifyFromObj - error} { - list [catch {.b configure -justify stupid} msg] $msg -} {1 {bad justification "stupid": must be left, right, or center}} +} -cleanup { + destroy .b +} -result {center} +test get-2.4 {Tk_GetJustifyFromObj - error} -setup { + button .b +} -body { + .b configure -justify stupid +} -cleanup { + destroy .b +} -returnCodes {error} -result {bad justification "stupid": must be left, right, or center} # cleanup cleanupTests return + |