Update to tcltest2

1 files changed, 371 insertions, 97 deletions

diff --git a/tests/msgbox.test b/tests/msgbox.test
index a351d0b..1056030 100644
--- a/tests/msgbox.test
+++ b/tests/msgbox.test
@@ -5,68 +5,82 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: msgbox.test,v 1.9 2004/05/24 21:23:23 dkf Exp $
+# RCS: @(#) $Id: msgbox.test,v 1.10 2008/08/21 11:19:33 aniap Exp $
 #
 
-package require tcltest 2.1
+package require tcltest 2.2
 eval tcltest::configure $argv
 tcltest::loadTestedCommands
+namespace import -force tcltest::test
 
-test msgbox-1.1 {tk_messageBox command} {
-    list [catch {tk_messageBox -foo} msg] $msg
-} {1 {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}}
-test msgbox-1.2 {tk_messageBox command} {
-    list [catch {tk_messageBox -foo bar} msg] $msg
-} {1 {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}}
-
-catch {tk_messageBox -foo bar} msg
-regsub -all ,      $msg "" options
-regsub \"-foo\" $options "" options
-
-foreach option $options {
-    if {[string index $option 0] eq "-"} {
-	test msgbox-1.3$option {tk_messageBox command} -body {
-	    tk_messageBox $option
-	} -returnCodes error -result "value for \"$option\" missing"
-    }
-}
 
-test msgbox-1.4 {tk_messageBox command} {
-    list [catch {tk_messageBox -default} msg] $msg
-} {1 {value for "-default" missing}}
+test msgbox-1.1 {tk_messageBox command} -body {
+    tk_messageBox -foo
+} -returnCodes error -result {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}
+test msgbox-1.2 {tk_messageBox command} -body {
+    tk_messageBox -foo bar
+} -returnCodes error -result {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}
 
-test msgbox-1.5 {tk_messageBox command} {
-    list [catch {tk_messageBox -type foo} msg] $msg
-} {1 {bad -type value "foo": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel}}
+test msgbox-1.3 {tk_messageBox command} -body {
+    tk_messageBox -default
+} -returnCodes error -result {value for "-default" missing}
+test msgbox-1.4 {tk_messageBox command} -body {
+    tk_messageBox -detail
+} -returnCodes error -result {value for "-detail" missing}
+test msgbox-1.5 {tk_messageBox command} -body {
+    tk_messageBox -icon
+} -returnCodes error -result {value for "-icon" missing}
+test msgbox-1.6 {tk_messageBox command} -body {
+    tk_messageBox -message
+} -returnCodes error -result {value for "-message" missing}
+test msgbox-1.7 {tk_messageBox command} -body {
+    tk_messageBox -parent
+} -returnCodes error -result {value for "-parent" missing}
+test msgbox-1.8 {tk_messageBox command} -body {
+    tk_messageBox -title
+} -returnCodes error -result {value for "-title" missing}
+test msgbox-1.9 {tk_messageBox command} -body {
+    tk_messageBox -type
+} -returnCodes error -result {value for "-type" missing}
 
-proc createPlatformMsg {val} {
-    global tcl_platform
-    if {$tcl_platform(platform) == "unix"} {
-	return "invalid default button \"$val\""
-    }
-    return "bad -default value \"$val\": must be abort, retry, ignore, ok, cancel, no, or yes"
-}
+test msgbox-1.10 {tk_messageBox command} -body {
+    tk_messageBox -default
+} -returnCodes error -result {value for "-default" missing}
+
+test msgbox-1.11 {tk_messageBox command} -body {
+    tk_messageBox -type foo
+} -returnCodes error -result {bad -type value "foo": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel}
 
-test msgbox-1.6 {tk_messageBox command} {
-    list [catch {tk_messageBox -default 1.1} msg] $msg
-} [list 1 [createPlatformMsg "1.1"]]
+test msgbox-1.12 {tk_messageBox command} -constraints unix -body {
+    tk_messageBox -default 1.1
+} -returnCodes error -result {invalid default button "1.1"}
+test msgbox-1.13 {tk_messageBox command} -constraints macOrWin -body {
+    tk_messageBox -default 1.1
+} -returnCodes error -result {bad -default value "1.1": must be abort, retry, ignore, ok, cancel, no, or yes}
 
-test msgbox-1.7 {tk_messageBox command} {
-    list [catch {tk_messageBox -default foo} msg] $msg
-} [list 1 [createPlatformMsg "foo"]]
+test msgbox-1.14 {tk_messageBox command} -constraints unix -body {
+    tk_messageBox -default foo
+} -returnCodes error -result {invalid default button "foo"}
+test msgbox-1.15 {tk_messageBox command} -constraints macOrWin -body {
+    tk_messageBox -default foo
+} -returnCodes error -result {bad -default value "foo": must be abort, retry, ignore, ok, cancel, no, or yes}
 
-test msgbox-1.8 {tk_messageBox command} {
-    list [catch {tk_messageBox -type yesno -default 3} msg] $msg
-} [list 1 [createPlatformMsg "3"]]
+test msgbox-1.16 {tk_messageBox command} -constraints unix -body {
+    tk_messageBox -type yesno -default 3
+} -returnCodes error -result {invalid default button "3"}
+test msgbox-1.17 {tk_messageBox command} -constraints macOrWin -body {
+    tk_messageBox -type yesno -default 3
+} -returnCodes error -result {bad -default value "3": must be abort, retry, ignore, ok, cancel, no, or yes}
 
-test msgbox-1.9 {tk_messageBox command} {
-    list [catch {tk_messageBox -icon foo} msg] $msg
-} {1 {bad -icon value "foo": must be error, info, question, or warning}}
+test msgbox-1.18 {tk_messageBox command} -body {
+    tk_messageBox -icon foo
+} -returnCodes error -result {bad -icon value "foo": must be error, info, question, or warning}
+test msgbox-1.19 {tk_messageBox command} -body {
+    tk_messageBox -parent foo.bar
+} -returnCodes error -result {bad window path name "foo.bar"}
 
-test msgbox-1.10 {tk_messageBox command} {
-    list [catch {tk_messageBox -parent foo.bar} msg] $msg
-} {1 {bad window path name "foo.bar"}}
 
+catch {tk_messageBox -foo bar}
 set isNative [expr {[info commands tk::MessageBox] == ""}]
 
 proc ChooseMsg {parent btn} {
@@ -107,72 +121,332 @@ proc SendEventToMsg {parent btn type} {
 	event generate $w <KeyPress> -keysym Return
     }
 }
-
-set parent .
-
-set specs {
-    {"abortretryignore"  MB_ABORTRETRYIGNORE  3  {"abort"  "retry"  "ignore"}} 
-    {"ok"  		 MB_OK  	      1  {"ok"                      }} 
-    {"okcancel" 	 MB_OKCANCEL 	      2  {"ok"     "cancel"         }} 
-    {"retrycancel" 	 MB_RETRYCANCEL       2  {"retry"  "cancel"         }} 
-    {"yesno" 		 MB_YESNO 	      2  {"yes"    "no"             }} 
-    {"yesnocancel" 	 MB_YESNOCANCEL       3  {"yes"    "no"     "cancel"}}
-}
-
 #
 # Try out all combinations of (type) x (default button) and
 # (type) x (icon).
 #
-set count 1
-foreach spec $specs {
-    set type [lindex $spec 0]
-    set buttons [lindex $spec 3]
-
-    set button [lindex $buttons 0]
-    test msgbox-2.$count {tk_messageBox command} nonUnixUserInteraction {
-	ChooseMsg $parent $button
-	tk_messageBox -title Hi -message "Please press $button" \
-		-type $type
-    } $button
-    incr count
-
-    foreach icon {warning error info question} {
-	test msgbox-2.$count {tk_messageBox command -icon option} \
-		nonUnixUserInteraction {
-	    ChooseMsg $parent $button
-	    tk_messageBox -title Hi -message "Please press $button" \
-		    -type $type -icon $icon
-	} $button
-        incr count
-    }
+test msgbox-2.1 {tk_messageBox command} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . abort
+    tk_messageBox -title Hi -message "Please press abort" -type abortretryignore
+} -result {abort}
+test msgbox-2.2 {tk_messageBox command -icon option} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . abort
+    tk_messageBox -title Hi -message "Please press abort" \
+        -type abortretryignore -icon warning
+} -result {abort}
+test msgbox-2.3 {tk_messageBox command -icon option} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . abort
+    tk_messageBox -title Hi -message "Please press abort" \
+        -type abortretryignore -icon error
+} -result {abort}
+test msgbox-2.4 {tk_messageBox command -icon option} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . abort
+    tk_messageBox -title Hi -message "Please press abort" \
+        -type abortretryignore -icon info
+} -result {abort}
+test msgbox-2.5 {tk_messageBox command -icon option} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . abort
+    tk_messageBox -title Hi -message "Please press abort" \
+        -type abortretryignore -icon question
+} -result {abort}
+test msgbox-2.6 {tk_messageBox command} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . abort
+    tk_messageBox -title Hi -message "Please press abort" \
+        -type abortretryignore -default abort
+} -result {abort}
+test msgbox-2.7 {tk_messageBox command} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . retry
+    tk_messageBox -title Hi -message "Please press retry" \
+        -type abortretryignore -default retry
+} -result {retry}
+test msgbox-2.8 {tk_messageBox command} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . ignore
+    tk_messageBox -title Hi -message "Please press ignore" \
+        -type abortretryignore -default ignore
+} -result {ignore}
+test msgbox-2.9 {tk_messageBox command} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . ok
+    tk_messageBox -title Hi -message "Please press ok" -type ok
+} -result {ok}
+test msgbox-2.10 {tk_messageBox command -icon option} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . ok
+    tk_messageBox -title Hi -message "Please press ok" \
+        -type ok -icon warning
+} -result {ok}
+test msgbox-2.11 {tk_messageBox command -icon option} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . ok
+    tk_messageBox -title Hi -message "Please press ok" \
+        -type ok -icon error
+} -result {ok}
+test msgbox-2.12 {tk_messageBox command -icon option} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . ok
+    tk_messageBox -title Hi -message "Please press ok" \
+        -type ok -icon info
+} -result {ok}
+test msgbox-2.13 {tk_messageBox command -icon option} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . ok
+    tk_messageBox -title Hi -message "Please press ok" \
+        -type ok -icon question
+} -result {ok}
+test msgbox-2.14 {tk_messageBox command} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . ok
+    tk_messageBox -title Hi -message "Please press ok" \
+        -type ok -default ok
+} -result {ok}
+test msgbox-2.15 {tk_messageBox command} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . ok
+    tk_messageBox -title Hi -message "Please press ok" -type okcancel
+} -result {ok}
+test msgbox-2.16 {tk_messageBox command -icon option} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . ok
+    tk_messageBox -title Hi -message "Please press ok" \
+        -type okcancel -icon warning
+} -result {ok}
+test msgbox-2.17 {tk_messageBox command -icon option} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . ok
+    tk_messageBox -title Hi -message "Please press ok" \
+        -type okcancel -icon error
+} -result {ok}
+test msgbox-2.18 {tk_messageBox command -icon option} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . ok
+    tk_messageBox -title Hi -message "Please press ok" \
+        -type okcancel -icon info
+} -result {ok}
+test msgbox-2.19 {tk_messageBox command -icon option} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . ok
+    tk_messageBox -title Hi -message "Please press ok" \
+        -type okcancel -icon question
+} -result {ok}
+test msgbox-2.20 {tk_messageBox command} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . ok
+    tk_messageBox -title Hi -message "Please press ok" \
+        -type okcancel -default ok
+} -result {ok}
+test msgbox-2.21 {tk_messageBox command} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . cancel
+    tk_messageBox -title Hi -message "Please press cancel" \
+        -type okcancel -default cancel
+} -result {cancel}
+test msgbox-2.22 {tk_messageBox command} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . retry
+    tk_messageBox -title Hi -message "Please press retry" -type retrycancel
+} -result {retry}
+test msgbox-2.23 {tk_messageBox command -icon option} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . retry
+    tk_messageBox -title Hi -message "Please press retry" \
+        -type retrycancel -icon warning
+} -result {retry}
+test msgbox-2.24 {tk_messageBox command -icon option} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . retry
+    tk_messageBox -title Hi -message "Please press retry" \
+        -type retrycancel -icon error
+} -result {retry}
+test msgbox-2.25 {tk_messageBox command -icon option} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . retry
+    tk_messageBox -title Hi -message "Please press retry" \
+        -type retrycancel -icon info
+} -result {retry}
+test msgbox-2.26 {tk_messageBox command -icon option} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . retry
+    tk_messageBox -title Hi -message "Please press retry" \
+        -type retrycancel -icon question
+} -result {retry}
+test msgbox-2.27 {tk_messageBox command} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . retry
+    tk_messageBox -title Hi -message "Please press retry" \
+        -type retrycancel -default retry
+} -result {retry}
+test msgbox-2.28 {tk_messageBox command} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . cancel
+    tk_messageBox -title Hi -message "Please press cancel" \
+        -type retrycancel -default cancel
+} -result {cancel}
+test msgbox-2.29 {tk_messageBox command} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . yes
+    tk_messageBox -title Hi -message "Please press yes" -type yesno
+} -result {yes}
+test msgbox-2.30 {tk_messageBox command -icon option} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . yes
+    tk_messageBox -title Hi -message "Please press yes" \
+        -type yesno -icon warning
+} -result {yes}
+test msgbox-2.31 {tk_messageBox command -icon option} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . yes
+    tk_messageBox -title Hi -message "Please press yes" \
+        -type yesno -icon error
+} -result {yes}
+test msgbox-2.32 {tk_messageBox command -icon option} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . yes
+    tk_messageBox -title Hi -message "Please press yes" \
+        -type yesno -icon info
+} -result {yes}
+test msgbox-2.33 {tk_messageBox command -icon option} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . yes
+    tk_messageBox -title Hi -message "Please press yes" \
+        -type yesno -icon question
+} -result {yes}
+test msgbox-2.34 {tk_messageBox command} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . yes
+    tk_messageBox -title Hi -message "Please press yes" \
+        -type yesno -default yes
+} -result {yes}
+test msgbox-2.35 {tk_messageBox command} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . no
+    tk_messageBox -title Hi -message "Please press no" \
+        -type yesno -default no
+} -result {no}
+test msgbox-2.36 {tk_messageBox command} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . yes
+    tk_messageBox -title Hi -message "Please press yes" -type yesnocancel
+} -result {yes}
+test msgbox-2.37 {tk_messageBox command -icon option} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . yes
+    tk_messageBox -title Hi -message "Please press yes" \
+        -type yesnocancel -icon warning
+} -result {yes}
+test msgbox-2.38 {tk_messageBox command -icon option} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . yes
+    tk_messageBox -title Hi -message "Please press yes" \
+        -type yesnocancel -icon error
+} -result {yes}
+test msgbox-2.39 {tk_messageBox command -icon option} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . yes
+    tk_messageBox -title Hi -message "Please press yes" \
+        -type yesnocancel -icon info
+} -result {yes}
+test msgbox-2.40 {tk_messageBox command -icon option} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . yes
+    tk_messageBox -title Hi -message "Please press yes" \
+        -type yesnocancel -icon question
+} -result {yes}
+test msgbox-2.41 {tk_messageBox command} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . yes
+    tk_messageBox -title Hi -message "Please press yes" \
+        -type yesnocancel -default yes
+} -result {yes}
+test msgbox-2.42 {tk_messageBox command} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . no
+    tk_messageBox -title Hi -message "Please press no" \
+        -type yesnocancel -default no
+} -result {no}
+test msgbox-2.43 {tk_messageBox command} -constraints {
+    nonUnixUserInteraction 
+} -body {
+    ChooseMsg . cancel
+    tk_messageBox -title Hi -message "Please press cancel" \
+        -type yesnocancel -default cancel
+} -result {cancel}
 
-    foreach button $buttons {
-	test msgbox-2.$count {tk_messageBox command} nonUnixUserInteraction {
-	    ChooseMsg $parent $button
-	    tk_messageBox -title Hi -message "Please press $button" \
-		    -type $type -default $button
-	} "$button"
-        incr count
-    }
-}
 
 # These tests will hang your test suite if they fail.
-test msgbox-3.1 {tk_messageBox handles withdrawn parent} nonUnixUserInteraction {
+test msgbox-3.1 {tk_messageBox handles withdrawn parent} -constraints {
+	nonUnixUserInteraction 
+} -body {
     wm withdraw .
     ChooseMsg . "ok"
     tk_messageBox -title Hi -message "Please press ok" \
 	    -type ok -default ok
-} "ok"
-wm deiconify .
+} -cleanup {
+    wm deiconify .
+} -result {ok}
 
-test msgbox-3.2 {tk_messageBox handles iconified parent} nonUnixUserInteraction {
+test msgbox-3.2 {tk_messageBox handles iconified parent} -constraints {
+	nonUnixUserInteraction 
+} -body {
     wm iconify .
     ChooseMsg . "ok"
     tk_messageBox -title Hi -message "Please press ok" \
 	    -type ok -default ok
-} "ok"
-wm deiconify .
+} -cleanup {
+    wm deiconify .
+} -result {ok}
 
 # cleanup
 cleanupTests
 return
+
+