Update to tcltest2

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
+