diff options
Diffstat (limited to 'tests/clrpick.test')
| -rw-r--r-- | tests/clrpick.test | 90 |
1 files changed, 56 insertions, 34 deletions
diff --git a/tests/clrpick.test b/tests/clrpick.test index 2e8d0bf..f06703b 100644 --- a/tests/clrpick.test +++ b/tests/clrpick.test @@ -1,18 +1,33 @@ # This file is a Tcl script to test out Tk's "tk_chooseColor" command. -# It is organized in the standard fashion for Tcl tests. # # Copyright © 1996 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2.2 -eval tcltest::configure $argv -tcltest::loadTestedCommands -namespace import -force tcltest::test +# +# TESTFILE INITIALIZATION +# + +package require tcltest 2.2; # needed in mode -singleproc 0 + +# Load the main script main.tcl, which takes care of: +# - setup for the application and the root window +# - importing commands from the tcltest namespace +# - loading of the testutils mechanism along with its utility procs +# - loading of Tk specific test constraints (additionally to constraints +# provided by the package tcltest) +source [file join [tcltest::configure -testdir] main.tcl] + +# Ensure a pristine initial window state +resetWindows # Import utility procs for specific functional areas testutils import dialog +# +# LOCAL TEST CONSTRAINTS +# + if {[testConstraint defaultPseudocolor8]} { # let's soak up a bunch of colors...so that # machines with small color palettes still fail. @@ -47,6 +62,41 @@ if {[testConstraint defaultPseudocolor8]} { testConstraint colorsLeftover 1 } +# +# LOCAL UTILITY PROCS +# + +proc ChooseColorByKey {parent r g b} { + set w .__tk__color + upvar ::tk::dialog::color::[winfo name $w] data + + update + $data(red,entry) delete 0 end + $data(green,entry) delete 0 end + $data(blue,entry) delete 0 end + + $data(red,entry) insert 0 $r + $data(green,entry) insert 0 $g + $data(blue,entry) insert 0 $b + + # Manually force the refresh of the color values instead + # of counting on the timing of the event stream to change + # the values for us. + tk::dialog::color::HandleRGBEntry $w + + SendButtonPress . ok mouse +} + +proc ToChooseColorByKey {parent r g b} { + if {! $::dialogIsNative} { + after 200 ChooseColorByKey . $r $g $b + } +} + +# +# TESTS +# + test clrpick-1.1 {tk_chooseColor command} -body { tk_chooseColor -foo } -returnCodes error -result {bad option "-foo": must be -initialcolor, -parent, or -title} @@ -77,33 +127,6 @@ test clrpick-1.7 {tk_chooseColor command} -body { tk_chooseColor -initialcolor ##badbadbaadcolor } -returnCodes error -result {invalid color name "##badbadbaadcolor"} -proc ToChooseColorByKey {parent r g b} { - if {! $::dialogIsNative} { - after 200 ChooseColorByKey . $r $g $b - } -} - -proc ChooseColorByKey {parent r g b} { - set w .__tk__color - upvar ::tk::dialog::color::[winfo name $w] data - - update - $data(red,entry) delete 0 end - $data(green,entry) delete 0 end - $data(blue,entry) delete 0 end - - $data(red,entry) insert 0 $r - $data(green,entry) insert 0 $g - $data(blue,entry) insert 0 $b - - # Manually force the refresh of the color values instead - # of counting on the timing of the event stream to change - # the values for us. - tk::dialog::color::HandleRGBEntry $w - - SendButtonPress . ok mouse -} - test clrpick-2.1 {tk_chooseColor command} -constraints { nonUnixUserInteraction colorsLeftover } -setup { @@ -160,9 +183,8 @@ test clrpick-4.1 {tk_chooseColor: screen is inherited from parent} -constraints } -result [winfo screen .] # -# CLEANUP +# TESTFILE CLEANUP # testutils forget dialog cleanupTests -return |