URL
https://opencores.org/ocsvn/or1k/or1k/trunk
Subversion Repositories or1k
[/] [or1k/] [tags/] [start/] [insight/] [tk/] [tests/] [clrpick.test] - Rev 578
Go to most recent revision | Compare with Previous | Blame | View Log
# 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.
#
# RCS: @(#) $Id: clrpick.test,v 1.1.1.1 2002-01-16 10:25:58 markom Exp $
#
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}}
catch {tk_chooseColor -foo} 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 {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
# let's soak up a bunch of colors...so that
# machines with small color palettes still fail.
set numcolors 32
set nomorecolors 0
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]"} {
set nomorecolors 1
}
}
.c delete $i
incr i
}
destroy .c
if {!$nomorecolors} {
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"
} else {
puts "Skipped tests clrpick2.1, clrpick2.2 and clrpick2.3 because"
puts "you ran out of colors in your color palette, and this would"
puts "have caused the tests to generate errors."
}
test clrpick-2.4 {tk_chooseColor command} {
ToPressButton $parent cancel
tk_chooseColor -parent $parent -title "Press Cancel"
} ""
set color #000000
test clrpick-3.1 {tk_chooseColor: background events} {
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} {
after 1 {set x 53}
ToPressButton $parent cancel
tk_chooseColor -parent $parent -title "Press Cancel"
} ""
Go to most recent revision | Compare with Previous | Blame | View Log