OpenCores
URL https://opencores.org/ocsvn/or1k_old/or1k_old/trunk

Subversion Repositories or1k_old

[/] [or1k_old/] [trunk/] [insight/] [tk/] [tests/] [clrpick.test] - Blame information for rev 1782

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 578 markom 
# 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 
#
6 
# See the file "license.terms" for information on usage and redistribution
7 
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
8 
#
9 
# RCS: @(#) $Id: clrpick.test,v 1.1.1.1 2002-01-16 10:25:58 markom Exp $
10 
#
11 
 
12 
if {[string compare test [info procs test]] == 1} {
13 
    source defs
14 
}
15 
 
16 
test clrpick-1.1 {tk_chooseColor command} {
17 
    list [catch {tk_chooseColor -foo} msg] $msg
18 
} {1 {unknown option "-foo", must be -initialcolor, -parent or -title}}
19 
 
20 
catch {tk_chooseColor -foo} msg
21 
regsub -all ,      $msg "" options
22 
regsub \"-foo\" $options "" options
23 
 
24 
foreach option $options {
25 
    if {[string index $option 0] == "-"} {
26 
        test clrpick-1.2 {tk_chooseColor command} {
27 
            list [catch {tk_chooseColor $option} msg] $msg
28 
        } [list 1 "value for \"$option\" missing"]
29 
    }
30 
}
31 
 
32 
test clrpick-1.3 {tk_chooseColor command} {
33 
    list [catch {tk_chooseColor -foo bar} msg] $msg
34 
} {1 {unknown option "-foo", must be -initialcolor, -parent or -title}}
35 
 
36 
test clrpick-1.4 {tk_chooseColor command} {
37 
    list [catch {tk_chooseColor -initialcolor} msg] $msg
38 
} {1 {value for "-initialcolor" missing}}
39 
 
40 
test clrpick-1.5 {tk_chooseColor command} {
41 
    list [catch {tk_chooseColor -parent foo.bar} msg] $msg
42 
} {1 {bad window path name "foo.bar"}}
43 
 
44 
test clrpick-1.6 {tk_chooseColor command} {
45 
    list [catch {tk_chooseColor -initialcolor badbadbaadcolor} msg] $msg
46 
} {1 {unknown color name "badbadbaadcolor"}}
47 
 
48 
test clrpick-1.7 {tk_chooseColor command} {
49 
    list [catch {tk_chooseColor -initialcolor ##badbadbaadcolor} msg] $msg
50 
} {1 {invalid color name "##badbadbaadcolor"}}
51 
 
52 
if {[info commands tkColorDialog] == ""} {
53 
    set isNative 1
54 
} else {
55 
    set isNative 0
56 
}
57 
 
58 
if {$isNative && ![info exists INTERACTIVE]} {
59 
    puts " Some tests were skipped because they could not be performed"
60 
    puts " automatically on this platform. If you wish to execute them"
61 
    puts " interactively, set the TCL variable INTERACTIVE and re-run"
62 
    puts " the test."
63 
    return
64 
}
65 
 
66 
proc ToPressButton {parent btn} {
67 
    global isNative
68 
    if {!$isNative} {
69 
        after 200 "SendButtonPress $parent $btn mouse"
70 
    }
71 
}
72 
 
73 
proc ToChooseColorByKey {parent r g b} {
74 
    global isNative
75 
    if {!$isNative} {
76 
        after 200 ChooseColorByKey $parent $r $g $b
77 
    }
78 
}
79 
 
80 
proc PressButton {btn} {
81 
    event generate $btn
82 
    event generate $btn <1> -x 5 -y 5
83 
    event generate $btn  -x 5 -y 5
84 
}
85 
 
86 
proc ChooseColorByKey {parent r g b} {
87 
    set w .__tk__color
88 
    upvar #0 $w data
89 
 
90 
    update
91 
    $data(red,entry)   delete 0 end
92 
    $data(green,entry) delete 0 end
93 
    $data(blue,entry)  delete 0 end
94 
 
95 
    $data(red,entry)   insert 0 $r
96 
    $data(green,entry) insert 0 $g
97 
    $data(blue,entry)  insert 0 $b
98 
 
99 
    # Manually force the refresh of the color values instead
100 
    # of counting on the timing of the event stream to change
101 
    # the values for us.
102 
    tkColorDialog_HandleRGBEntry $w
103 
 
104 
    SendButtonPress $parent ok mouse
105 
}
106 
 
107 
proc SendButtonPress {parent btn type} {
108 
    set w .__tk__color
109 
    upvar #0 $w data
110 
 
111 
    set button $data($btn\Btn)
112 
    if ![winfo ismapped $button] {
113 
        update
114 
    }
115 
 
116 
    if {$type == "mouse"} {
117 
        PressButton $button
118 
    } else {
119 
        event generate $w
120 
        focus $w
121 
        event generate $button
122 
        event generate $w  -keysym Return
123 
    }
124 
}
125 
 
126 
set parent .
127 
 
128 
set verylongstring longstring:
129 
set verylongstring $verylongstring$verylongstring
130 
set verylongstring $verylongstring$verylongstring
131 
set verylongstring $verylongstring$verylongstring
132 
set verylongstring $verylongstring$verylongstring
133 
#set verylongstring $verylongstring$verylongstring
134 
# Interesting thing...when this is too long, the
135 
# delay caused in processing it kills the automated testing,
136 
# and makes a lot of the test cases fail.
137 
#set verylongstring $verylongstring$verylongstring
138 
#set verylongstring $verylongstring$verylongstring
139 
#set verylongstring $verylongstring$verylongstring
140 
#set verylongstring $verylongstring$verylongstring
141 
 
142 
# let's soak up a bunch of colors...so that
143 
# machines with small color palettes still fail.
144 
set numcolors 32
145 
set nomorecolors 0
146 
set i 0
147 
canvas .c
148 
pack .c -expand 1 -fill both
149 
while {$i<$numcolors} {
150 
    set color \#[format "%02x%02x%02x" $i [expr $i+1] [expr $i+3]]
151 
    .c create rectangle [expr 10+$i] [expr 10+$i] [expr 50+$i] [expr 50+$i] -fill $color -outline $color
152 
    incr i
153 
}
154 
set i 0
155 
while {$i<$numcolors} {
156 
    set color [.c itemcget $i -fill]
157 
    if {$color != ""} {
158 
        foreach {r g b} [winfo rgb . $color] {}
159 
        set r [expr $r/256]
160 
        set g [expr $g/256]
161 
        set b [expr $b/256]
162 
        if {"$color" != "#[format %02x%02x%02x $r $g $b]"} {
163 
            set nomorecolors 1
164 
        }
165 
    }
166 
    .c delete $i
167 
    incr i
168 
}
169 
 
170 
destroy .c
171 
 
172 
if {!$nomorecolors} {
173 
    set color #404040
174 
    test clrpick-2.1 {tk_chooseColor command} {
175 
        ToPressButton $parent ok
176 
        tk_chooseColor -title "Press Ok $verylongstring" -initialcolor $color -parent $parent
177 
    } "$color"
178 
 
179 
    set color #808040
180 
    test clrpick-2.2 {tk_chooseColor command} {
181 
        if {$tcl_platform(platform) == "macintosh"} {
182 
            set colors "32768 32768 16384"
183 
        } else {
184 
            set colors "128 128 64"
185 
        }
186 
        ToChooseColorByKey $parent 128 128 64
187 
        tk_chooseColor -parent $parent -title "choose $colors"
188 
    } "$color"
189 
 
190 
    test clrpick-2.3 {tk_chooseColor command} {
191 
        ToPressButton $parent ok
192 
        tk_chooseColor -parent $parent -title "Press OK"
193 
    } "$color"
194 
} else {
195 
    puts "Skipped tests clrpick2.1, clrpick2.2 and clrpick2.3 because"
196 
    puts "you ran out of colors in your color palette, and this would"
197 
    puts "have caused the tests to generate errors."
198 
}
199 
 
200 
test clrpick-2.4 {tk_chooseColor command} {
201 
    ToPressButton $parent cancel
202 
    tk_chooseColor -parent $parent -title "Press Cancel"
203 
} ""
204 
 
205 
set color #000000
206 
test clrpick-3.1 {tk_chooseColor: background events} {
207 
    after 1 {set x 53}
208 
    ToPressButton $parent ok
209 
    tk_chooseColor -parent $parent -title "Press OK" -initialcolor $color
210 
} "#000000"
211 
test clrpick-3.2 {tk_chooseColor: background events} {
212 
    after 1 {set x 53}
213 
    ToPressButton $parent cancel
214 
    tk_chooseColor -parent $parent -title "Press Cancel"
215 
} ""

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.