Import Tk 8.5.15 (as of svn r89086)
This commit is contained in:
Zachary Ware
201
tests/clrpick.test
Normal file
201
tests/clrpick.test
Normal file
@@ -0,0 +1,201 @@
|
||||
# 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.1
|
||||
eval tcltest::configure $argv
|
||||
tcltest::loadTestedCommands
|
||||
|
||||
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} {
|
||||
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] eq "-"} {
|
||||
test clrpick-1.2$option {tk_chooseColor command} -body {
|
||||
tk_chooseColor $option
|
||||
} -returnCodes error -result "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"}}
|
||||
|
||||
set isNative [expr {[info commands tk::dialog::color::] eq ""}]
|
||||
|
||||
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 ::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 <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
|
||||
|
||||
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} {
|
||||
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} {unix notAqua} {
|
||||
after 50 {set ::scr [winfo screen .__tk__color]}
|
||||
ToPressButton $parent cancel
|
||||
tk_chooseColor -parent $parent
|
||||
set ::scr
|
||||
} [winfo screen $parent]
|
||||
|
||||
# cleanup
|
||||
cleanupTests
|
||||
return
|
||||
Reference in New Issue
Block a user