219 lines
6.6 KiB
Plaintext
219 lines
6.6 KiB
Plaintext
# 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
|
|
|
|
testConstraint failsOnXQuarz [expr {$tcl_platform(os) ne "Darwin" || [tk windowingsystem] ne "x11" }]
|
|
|
|
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 failsOnXQuarz
|
|
} -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
|
|
|