diff options
Diffstat (limited to 'tests/clrpick.test')
| -rw-r--r-- | tests/clrpick.test | 191 |
1 files changed, 103 insertions, 88 deletions
diff --git a/tests/clrpick.test b/tests/clrpick.test index 8b3769e..5f1b8b5 100644 --- a/tests/clrpick.test +++ b/tests/clrpick.test @@ -5,9 +5,10 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -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 @@ -43,51 +44,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.1 {tk_chooseColor command } -body { + tk_chooseColor -parent +} -returnCodes error -result {value for "-parent" missing} +test clrpick-1.2.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 } } @@ -115,7 +119,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} { @@ -137,65 +141,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 + |