1# This file is a Tcl script to test out Tk's "tk_chooseColor" command. 2# It is organized in the standard fashion for Tcl tests. 3# 4# Copyright (c) 1996 Sun Microsystems, Inc. 5# Copyright (c) 1998-1999 by Scriptics Corporation. 6# All rights reserved. 7# 8# RCS: @(#) $Id$ 9# 10 11package require tcltest 2.1 12eval tcltest::configure $argv 13tcltest::loadTestedCommands 14 15if {[testConstraint defaultPseudocolor8]} { 16 # let's soak up a bunch of colors...so that 17 # machines with small color palettes still fail. 18 # some tests will be skipped if there are no more colors 19 set numcolors 32 20 testConstraint colorsLeftover 1 21 set i 0 22 canvas .c 23 pack .c -expand 1 -fill both 24 while {$i<$numcolors} { 25 set color \#[format "%02x%02x%02x" $i [expr $i+1] [expr $i+3]] 26 .c create rectangle [expr 10+$i] [expr 10+$i] [expr 50+$i] [expr 50+$i] -fill $color -outline $color 27 incr i 28 } 29 set i 0 30 while {$i<$numcolors} { 31 set color [.c itemcget $i -fill] 32 if {$color != ""} { 33 foreach {r g b} [winfo rgb . $color] {} 34 set r [expr $r/256] 35 set g [expr $g/256] 36 set b [expr $b/256] 37 if {"$color" != "#[format %02x%02x%02x $r $g $b]"} { 38 testConstraint colorsLeftover 0 39 } 40 } 41 .c delete $i 42 incr i 43 } 44 destroy .c 45} else { 46 testConstraint colorsLeftover 0 47} 48 49test clrpick-1.1 {tk_chooseColor command} { 50 list [catch {tk_chooseColor -foo} msg] $msg 51} {1 {bad option "-foo": must be -initialcolor, -parent, or -title}} 52 53catch {tk_chooseColor -foo 1} msg 54regsub -all , $msg "" options 55regsub \"-foo\" $options "" options 56 57foreach option $options { 58 if {[string index $option 0] eq "-"} { 59 test clrpick-1.2$option {tk_chooseColor command} -body { 60 tk_chooseColor $option 61 } -returnCodes error -result "value for \"$option\" missing" 62 } 63} 64 65test clrpick-1.3 {tk_chooseColor command} { 66 list [catch {tk_chooseColor -foo bar} msg] $msg 67} {1 {bad option "-foo": must be -initialcolor, -parent, or -title}} 68test clrpick-1.4 {tk_chooseColor command} { 69 list [catch {tk_chooseColor -initialcolor} msg] $msg 70} {1 {value for "-initialcolor" missing}} 71test clrpick-1.5 {tk_chooseColor command} { 72 list [catch {tk_chooseColor -parent foo.bar} msg] $msg 73} {1 {bad window path name "foo.bar"}} 74test clrpick-1.6 {tk_chooseColor command} { 75 list [catch {tk_chooseColor -initialcolor badbadbaadcolor} msg] $msg 76} {1 {unknown color name "badbadbaadcolor"}} 77test clrpick-1.7 {tk_chooseColor command} { 78 list [catch {tk_chooseColor -initialcolor ##badbadbaadcolor} msg] $msg 79} {1 {invalid color name "##badbadbaadcolor"}} 80 81set isNative [expr {[info commands tk::dialog::color::] eq ""}] 82 83proc ToPressButton {parent btn} { 84 global isNative 85 if {!$isNative} { 86 after 200 "SendButtonPress $parent $btn mouse" 87 } 88} 89 90proc ToChooseColorByKey {parent r g b} { 91 global isNative 92 if {!$isNative} { 93 after 200 ChooseColorByKey $parent $r $g $b 94 } 95} 96 97proc PressButton {btn} { 98 event generate $btn <Enter> 99 event generate $btn <1> -x 5 -y 5 100 event generate $btn <ButtonRelease-1> -x 5 -y 5 101} 102 103proc ChooseColorByKey {parent r g b} { 104 set w .__tk__color 105 upvar ::tk::dialog::color::[winfo name $w] data 106 107 update 108 $data(red,entry) delete 0 end 109 $data(green,entry) delete 0 end 110 $data(blue,entry) delete 0 end 111 112 $data(red,entry) insert 0 $r 113 $data(green,entry) insert 0 $g 114 $data(blue,entry) insert 0 $b 115 116 # Manually force the refresh of the color values instead 117 # of counting on the timing of the event stream to change 118 # the values for us. 119 tk::dialog::color::HandleRGBEntry $w 120 121 SendButtonPress $parent ok mouse 122} 123 124proc SendButtonPress {parent btn type} { 125 set w .__tk__color 126 upvar ::tk::dialog::color::[winfo name $w] data 127 128 set button $data($btn\Btn) 129 if ![winfo ismapped $button] { 130 update 131 } 132 133 if {$type == "mouse"} { 134 PressButton $button 135 } else { 136 event generate $w <Enter> 137 focus $w 138 event generate $button <Enter> 139 event generate $w <KeyPress> -keysym Return 140 } 141} 142 143set parent . 144 145set verylongstring longstring: 146set verylongstring $verylongstring$verylongstring 147set verylongstring $verylongstring$verylongstring 148set verylongstring $verylongstring$verylongstring 149set verylongstring $verylongstring$verylongstring 150#set verylongstring $verylongstring$verylongstring 151# Interesting thing...when this is too long, the 152# delay caused in processing it kills the automated testing, 153# and makes a lot of the test cases fail. 154#set verylongstring $verylongstring$verylongstring 155#set verylongstring $verylongstring$verylongstring 156#set verylongstring $verylongstring$verylongstring 157#set verylongstring $verylongstring$verylongstring 158 159set color #404040 160test clrpick-2.1 {tk_chooseColor command} \ 161 {nonUnixUserInteraction colorsLeftover} { 162 ToPressButton $parent ok 163 tk_chooseColor -title "Press Ok $verylongstring" -initialcolor $color \ 164 -parent $parent 165} "$color" 166set color #808040 167test clrpick-2.2 {tk_chooseColor command} \ 168 {nonUnixUserInteraction colorsLeftover} { 169 set colors "128 128 64" 170 ToChooseColorByKey $parent 128 128 64 171 tk_chooseColor -parent $parent -title "choose $colors" 172} "$color" 173test clrpick-2.3 {tk_chooseColor command} \ 174 {nonUnixUserInteraction colorsLeftover} { 175 ToPressButton $parent ok 176 tk_chooseColor -parent $parent -title "Press OK" 177} "$color" 178test clrpick-2.4 {tk_chooseColor command} {nonUnixUserInteraction} { 179 ToPressButton $parent cancel 180 tk_chooseColor -parent $parent -title "Press Cancel" 181} "" 182 183set color "#000000" 184test clrpick-3.1 {tk_chooseColor: background events} {nonUnixUserInteraction} { 185 after 1 {set x 53} 186 ToPressButton $parent ok 187 tk_chooseColor -parent $parent -title "Press OK" -initialcolor $color 188} "#000000" 189test clrpick-3.2 {tk_chooseColor: background events} {nonUnixUserInteraction} { 190 after 1 {set x 53} 191 ToPressButton $parent cancel 192 tk_chooseColor -parent $parent -title "Press Cancel" 193} "" 194 195test clrpick-4.1 {tk_chooseColor: screen is inherited from parent} {unix notAqua} { 196 after 50 {set ::scr [winfo screen .__tk__color]} 197 ToPressButton $parent cancel 198 tk_chooseColor -parent $parent 199 set ::scr 200} [winfo screen $parent] 201 202# cleanup 203cleanupTests 204return 205