archie/tk4.2/tests/clrpick.test
2024-05-27 16:40:40 +02:00

167 lines
4.7 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.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# @(#) clrpick.test 1.6 96/10/07 11:46:02
#
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}}
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
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"
test clrpick-2.4 {tk_chooseColor command} {
ToPressButton $parent cancel
tk_chooseColor -parent $parent -title "Press Cancel"
} ""