diff options
Diffstat (limited to 'tk8.6/tests/clrpick.test')
| -rw-r--r-- | tk8.6/tests/clrpick.test | 216 |
1 files changed, 0 insertions, 216 deletions
diff --git a/tk8.6/tests/clrpick.test b/tk8.6/tests/clrpick.test deleted file mode 100644 index 5f1b8b5..0000000 --- a/tk8.6/tests/clrpick.test +++ /dev/null @@ -1,216 +0,0 @@ -# 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 (c) 1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# All rights reserved. - -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 - # machines with small color palettes still fail. - # some tests will be skipped if there are no more colors - set numcolors 32 - testConstraint colorsLeftover 1 - set i 0 - canvas .c - pack .c -expand 1 -fill both - while {$i<$numcolors} { - set color \#[format "%02x%02x%02x" $i [expr $i+1] [expr $i+3]] - .c create rectangle [expr 10+$i] [expr 10+$i] [expr 50+$i] [expr 50+$i] -fill $color -outline $color - incr i - } - set i 0 - while {$i<$numcolors} { - set color [.c itemcget $i -fill] - if {$color != ""} { - foreach {r g b} [winfo rgb . $color] {} - set r [expr $r/256] - set g [expr $g/256] - set b [expr $b/256] - if {"$color" != "#[format %02x%02x%02x $r $g $b]"} { - testConstraint colorsLeftover 0 - } - } - .c delete $i - incr i - } - destroy .c -} else { - testConstraint colorsLeftover 0 -} - -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 . $btn mouse" - } -} - -proc ToChooseColorByKey {parent r g b} { - global isNative - if {!$isNative} { - after 200 ChooseColorByKey . $r $g $b - } -} - -proc PressButton {btn} { - event generate $btn <Enter> - event generate $btn <1> -x 5 -y 5 - event generate $btn <ButtonRelease-1> -x 5 -y 5 -} - -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 SendButtonPress {parent btn type} { - set w .__tk__color - upvar ::tk::dialog::color::[winfo name $w] data - - set button $data($btn\Btn) - if ![winfo ismapped $button] { - update - } - - if {$type == "mouse"} { - PressButton $button - } else { - event generate $w <Enter> - focus $w - event generate $button <Enter> - event generate $w <KeyPress> -keysym Return - } -} - - - -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 . 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 . 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 . cancel - tk_chooseColor -parent . -title "Press Cancel" -} -result {} - - -test clrpick-4.1 {tk_chooseColor: screen is inherited from parent} -constraints { - unix notAqua -} -body { - after 50 {set ::scr [winfo screen .__tk__color]} - ToPressButton . cancel - tk_chooseColor -parent . - set ::scr -} -result [winfo screen .] - -# cleanup -cleanupTests -return - |