diff options
Diffstat (limited to 'tests/clrpick.test')
| -rw-r--r-- | tests/clrpick.test | 215 |
1 files changed, 215 insertions, 0 deletions
diff --git a/tests/clrpick.test b/tests/clrpick.test new file mode 100644 index 0000000..d267224 --- /dev/null +++ b/tests/clrpick.test @@ -0,0 +1,215 @@ +# 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. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# @(#) clrpick.test 1.9 97/10/21 11:29:53 +# + +if {[string compare test [info procs test]] == 1} { + source defs +} + +test clrpick-1.1 {tk_chooseColor command} { + list [catch {tk_chooseColor -foo} msg] $msg +} {1 {unknown option "-foo", must be -initialcolor, -parent or -title}} + +catch {tk_chooseColor -foo} msg +regsub -all , $msg "" options +regsub \"-foo\" $options "" options + +foreach option $options { + if {[string index $option 0] == "-"} { + test clrpick-1.2 {tk_chooseColor command} { + list [catch {tk_chooseColor $option} msg] $msg + } [list 1 "value for \"$option\" missing"] + } +} + +test clrpick-1.3 {tk_chooseColor command} { + list [catch {tk_chooseColor -foo bar} msg] $msg +} {1 {unknown 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"}} + +if {[info commands tkColorDialog] == ""} { + set isNative 1 +} else { + set isNative 0 +} + +if {$isNative && ![info exists INTERACTIVE]} { + puts " Some tests were skipped because they could not be performed" + puts " automatically on this platform. If you wish to execute them" + puts " interactively, set the TCL variable INTERACTIVE and re-run" + puts " the test." + return +} + +proc ToPressButton {parent btn} { + global isNative + if {!$isNative} { + after 200 "SendButtonPress $parent $btn mouse" + } +} + +proc ToChooseColorByKey {parent r g b} { + global isNative + if {!$isNative} { + after 200 ChooseColorByKey $parent $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 #0 $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. + tkColorDialog_HandleRGBEntry $w + + SendButtonPress $parent ok mouse +} + +proc SendButtonPress {parent btn type} { + set w .__tk__color + upvar #0 $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 + } +} + +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 + +# let's soak up a bunch of colors...so that +# machines with small color palettes still fail. +set numcolors 32 +set nomorecolors 0 +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]"} { + set nomorecolors 1 + } + } + .c delete $i + incr i +} + +destroy .c + +if {!$nomorecolors} { + set color #404040 + test clrpick-2.1 {tk_chooseColor command} { + ToPressButton $parent ok + tk_chooseColor -title "Press Ok $verylongstring" -initialcolor $color -parent $parent + } "$color" + + set color #808040 + test clrpick-2.2 {tk_chooseColor command} { + if {$tcl_platform(platform) == "macintosh"} { + set colors "32768 32768 16384" + } else { + 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} { + ToPressButton $parent ok + tk_chooseColor -parent $parent -title "Press OK" + } "$color" +} else { + puts "Skipped tests clrpick2.1, clrpick2.2 and clrpick2.3 because" + puts "you ran out of colors in your color palette, and this would" + puts "have caused the tests to generate errors." +} + +test clrpick-2.4 {tk_chooseColor command} { + ToPressButton $parent cancel + tk_chooseColor -parent $parent -title "Press Cancel" +} "" + +set color #000000 +test clrpick-3.1 {tk_chooseColor: background events} { + 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} { + after 1 {set x 53} + ToPressButton $parent cancel + tk_chooseColor -parent $parent -title "Press Cancel" +} "" |