Update to tcltest2

1 files changed, 104 insertions, 89 deletions

diff --git a/tests/clrpick.test b/tests/clrpick.test
index 874a532..0502a69 100644
--- a/tests/clrpick.test
+++ b/tests/clrpick.test
@@ -5,12 +5,13 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: clrpick.test,v 1.13 2007/05/09 12:52:44 das Exp $
+# RCS: @(#) $Id: clrpick.test,v 1.14 2008/08/15 01:10:03 aniap Exp $
 #
 
-package require tcltest 2.1
+package require tcltest 2.2
 eval tcltest::configure $argv
 tcltest::loadTestedCommands
+namespace import -force tcltest::test
 
 if {[testConstraint defaultPseudocolor8]} {
     # let's soak up a bunch of colors...so that
@@ -46,51 +47,54 @@ if {[testConstraint defaultPseudocolor8]} {
     testConstraint colorsLeftover 0
 }
 
-test clrpick-1.1 {tk_chooseColor command} {
-    list [catch {tk_chooseColor -foo} msg] $msg
-} {1 {bad option "-foo": must be -initialcolor, -parent, or -title}}
-
-catch {tk_chooseColor -foo 1} msg
-regsub -all ,      $msg "" options
-regsub \"-foo\" $options "" options
-
-foreach option $options {
-    if {[string index $option 0] eq "-"} {
-	test clrpick-1.2$option {tk_chooseColor command} -body {
-	    tk_chooseColor $option
-	} -returnCodes error -result "value for \"$option\" missing"
-    }
-}
-
-test clrpick-1.3 {tk_chooseColor command} {
-    list [catch {tk_chooseColor -foo bar} msg] $msg
-} {1 {bad option "-foo": must be -initialcolor, -parent, or -title}}
-test clrpick-1.4 {tk_chooseColor command} {
-    list [catch {tk_chooseColor -initialcolor} msg] $msg
-} {1 {value for "-initialcolor" missing}}
-test clrpick-1.5 {tk_chooseColor command} {
-    list [catch {tk_chooseColor -parent foo.bar} msg] $msg
-} {1 {bad window path name "foo.bar"}}
-test clrpick-1.6 {tk_chooseColor command} {
-    list [catch {tk_chooseColor -initialcolor badbadbaadcolor} msg] $msg
-} {1 {unknown color name "badbadbaadcolor"}}
-test clrpick-1.7 {tk_chooseColor command} {
-    list [catch {tk_chooseColor -initialcolor ##badbadbaadcolor} msg] $msg
-} {1 {invalid color name "##badbadbaadcolor"}}
-
+test clrpick-1.1 {tk_chooseColor command} -body {
+    tk_chooseColor -foo
+} -returnCodes error -result {bad option "-foo": must be -initialcolor, -parent, or -title}
+
+test clrpick-1.2 {tk_chooseColor command } -body {
+    tk_chooseColor -initialcolor
+} -returnCodes error -result {value for "-initialcolor" missing}
+test clrpick-1.2 {tk_chooseColor command } -body {
+    tk_chooseColor -parent
+} -returnCodes error -result {value for "-parent" missing}
+test clrpick-1.2 {tk_chooseColor command } -body {
+    tk_chooseColor -title
+} -returnCodes error -result {value for "-title" missing}
+
+test clrpick-1.3 {tk_chooseColor command} -body {
+    tk_chooseColor -foo bar
+} -returnCodes error -result {bad option "-foo": must be -initialcolor, -parent, or -title}
+test clrpick-1.4 {tk_chooseColor command} -body {
+    tk_chooseColor -initialcolor
+} -returnCodes error -result {value for "-initialcolor" missing}
+test clrpick-1.5 {tk_chooseColor command} -body {
+    tk_chooseColor -parent foo.bar
+} -returnCodes error -result {bad window path name "foo.bar"}
+test clrpick-1.6 {tk_chooseColor command} -body {
+    tk_chooseColor -initialcolor badbadbaadcolor
+} -returnCodes error -result {unknown color name "badbadbaadcolor"}
+test clrpick-1.7 {tk_chooseColor command} -body {
+    tk_chooseColor -initialcolor ##badbadbaadcolor
+} -returnCodes error -result {invalid color name "##badbadbaadcolor"}
+
+
+# tests 3.1 and 3.2 fail when individually run
+# if there is no catch {tk_chooseColor -foo 1} msg
+# before settin isNative
+catch {tk_chooseColor -foo 1} msg 
 set isNative [expr {[info commands tk::dialog::color::] eq ""}]
 
 proc ToPressButton {parent btn} {
     global isNative
     if {!$isNative} {
-	after 200 "SendButtonPress $parent $btn mouse"
+	after 200 "SendButtonPress . $btn mouse"
     }
 }
 
 proc ToChooseColorByKey {parent r g b} {
     global isNative
     if {!$isNative} {
-	after 200 ChooseColorByKey $parent $r $g $b
+	after 200 ChooseColorByKey . $r $g $b
     }
 }
 
@@ -118,7 +122,7 @@ proc ChooseColorByKey {parent r g b} {
     # the values for us.
     tk::dialog::color::HandleRGBEntry $w
 
-    SendButtonPress $parent ok mouse
+    SendButtonPress . ok mouse
 }
 
 proc SendButtonPress {parent btn type} {
@@ -140,65 +144,76 @@ proc SendButtonPress {parent btn type} {
     }
 }
 
-set parent .
-
-set verylongstring longstring:
-set verylongstring $verylongstring$verylongstring
-set verylongstring $verylongstring$verylongstring
-set verylongstring $verylongstring$verylongstring
-set verylongstring $verylongstring$verylongstring
-#set verylongstring $verylongstring$verylongstring
-# Interesting thing...when this is too long, the
-# delay caused in processing it kills the automated testing,
-# and makes a lot of the test cases fail.
-#set verylongstring $verylongstring$verylongstring
-#set verylongstring $verylongstring$verylongstring
-#set verylongstring $verylongstring$verylongstring
-#set verylongstring $verylongstring$verylongstring
-
-set color #404040
-test clrpick-2.1 {tk_chooseColor command} \
-	{nonUnixUserInteraction colorsLeftover} {
-    ToPressButton $parent ok
-    tk_chooseColor -title "Press Ok $verylongstring" -initialcolor $color \
-	    -parent $parent
-} "$color"
-set color #808040
-test clrpick-2.2 {tk_chooseColor command} \
-	{nonUnixUserInteraction colorsLeftover} {
+
+
+test clrpick-2.1 {tk_chooseColor command} -constraints {
+    nonUnixUserInteraction colorsLeftover
+} -setup {
+    set verylongstring longstring:
+    set verylongstring $verylongstring$verylongstring
+    set verylongstring $verylongstring$verylongstring
+    set verylongstring $verylongstring$verylongstring
+    set verylongstring $verylongstring$verylongstring
+    #set verylongstring $verylongstring$verylongstring
+    # Interesting thing...when this is too long, the
+    # delay caused in processing it kills the automated testing,
+    # and makes a lot of the test cases fail.
+    #set verylongstring $verylongstring$verylongstring
+    #set verylongstring $verylongstring$verylongstring
+    #set verylongstring $verylongstring$verylongstring
+    #set verylongstring $verylongstring$verylongstring
+} -body {
+    ToPressButton . ok
+    tk_chooseColor -title "Press Ok $verylongstring" -initialcolor #404040 \
+        -parent .
+} -result {#404040}
+test clrpick-2.2 {tk_chooseColor command} -constraints {
+    nonUnixUserInteraction colorsLeftover
+} -body {
     set colors "128 128 64"
-    ToChooseColorByKey $parent 128 128 64
-    tk_chooseColor -parent $parent -title "choose $colors"
-} "$color"
-test clrpick-2.3 {tk_chooseColor command} \
-	{nonUnixUserInteraction colorsLeftover} {
-    ToPressButton $parent ok
-    tk_chooseColor -parent $parent -title "Press OK"
-} "$color"
-test clrpick-2.4 {tk_chooseColor command} {nonUnixUserInteraction} {
-    ToPressButton $parent cancel
-    tk_chooseColor -parent $parent -title "Press Cancel"
-} ""
-
-set color "#000000"
-test clrpick-3.1 {tk_chooseColor: background events} {nonUnixUserInteraction} {
+    ToChooseColorByKey . 128 128 64
+    tk_chooseColor -parent . -title "choose #808040"
+} -result {#808040}
+test clrpick-2.3 {tk_chooseColor command} -constraints {
+    nonUnixUserInteraction colorsLeftover
+} -body {
+    ToPressButton . ok
+    tk_chooseColor -parent . -title "Press OK"
+} -result {#808040}
+test clrpick-2.4 {tk_chooseColor command} -constraints {
+    nonUnixUserInteraction colorsLeftover
+} -body {
+    ToPressButton . cancel
+    tk_chooseColor -parent . -title "Press Cancel"
+} -result {}
+
+
+test clrpick-3.1 {tk_chooseColor: background events} -constraints {
+	nonUnixUserInteraction
+} -body {
     after 1 {set x 53}
-    ToPressButton $parent ok
-    tk_chooseColor -parent $parent -title "Press OK" -initialcolor $color
-} "#000000"
-test clrpick-3.2 {tk_chooseColor: background events} {nonUnixUserInteraction} {
+    ToPressButton . ok
+    tk_chooseColor -parent . -title "Press OK" -initialcolor #000000
+} -result {#000000}
+test clrpick-3.2 {tk_chooseColor: background events} -constraints {
+	nonUnixUserInteraction
+} -body {
     after 1 {set x 53}
-    ToPressButton $parent cancel
-    tk_chooseColor -parent $parent -title "Press Cancel"
-} ""
+    ToPressButton . cancel
+    tk_chooseColor -parent . -title "Press Cancel"
+} -result {}
 
-test clrpick-4.1 {tk_chooseColor: screen is inherited from parent} {unix notAqua} {
+
+test clrpick-4.1 {tk_chooseColor: screen is inherited from parent} -constraints {
+	unix notAqua
+} -body {
     after 50 {set ::scr [winfo screen .__tk__color]}
-    ToPressButton $parent cancel
-    tk_chooseColor -parent $parent
+    ToPressButton . cancel
+    tk_chooseColor -parent .
     set ::scr
-} [winfo screen $parent]
+} -result [winfo screen .]
 
 # cleanup
 cleanupTests
 return
+