summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--tests/cmds.test52
-rw-r--r--tests/dialog.test77
-rw-r--r--tests/get.test134
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
+