# 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. # # RCS: @(#) $Id: clrpick.test,v 1.1.1.1 2007/07/10 15:05:18 duncan Exp $ # package require tcltest 2.1 namespace import -force tcltest::configure namespace import -force tcltest::testsDirectory configure -testdir [file join [pwd] [file dirname [info script]]] configure -loadfile [file join [testsDirectory] constraints.tcl] tcltest::loadTestedCommands 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] == "-"} { 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 {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"}} if {[info commands tk::dialog::color::] == ""} { set isNative 1 } else { set isNative 0 } 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 event generate $btn <1> -x 5 -y 5 event generate $btn -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 $parent 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 focus $w event generate $button event generate $w -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. # 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 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} { 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} \ {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} { 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} { after 1 {set x 53} ToPressButton $parent cancel tk_chooseColor -parent $parent -title "Press Cancel" } "" test clrpick-4.1 {tk_chooseColor: screen is inherited from parent} unixOnly { after 50 {set ::scr [winfo screen .__tk__color]} ToPressButton $parent cancel tk_chooseColor -parent $parent set ::scr } [winfo screen $parent] # cleanup ::tcltest::cleanupTests return