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

Subversion Repositories or1k

[/] [or1k/] [tags/] [start/] [insight/] [tk/] [tests/] [image.test] - Blame information for rev 579

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 578 markom 
# This file is a Tcl script to test out the "image" command and the
2 
# other procedures in the file tkImage.c.  It is organized in the
3 
# standard fashion for Tcl tests.
4 
#
5 
# Copyright (c) 1994 The Regents of the University of California.
6 
# Copyright (c) 1994 Sun Microsystems, Inc.
7 
#
8 
# See the file "license.terms" for information on usage and redistribution
9 
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
10 
#
11 
# RCS: @(#) $Id: image.test,v 1.1.1.1 2002-01-16 10:25:58 markom Exp $
12 
 
13 
if {[lsearch [image types] test] < 0} {
14 
    puts "This application hasn't been compiled with the \"test\" image"
15 
    puts "type, so I can't run this test.  Are you sure you're using"
16 
    puts "tktest instead of wish?"
17 
    return
18 
}
19 
 
20 
if {[info procs test] != "test"} {
21 
    source defs
22 
}
23 
 
24 
foreach i [winfo children .] {
25 
    destroy $i
26 
}
27 
wm geometry . {}
28 
raise .
29 
 
30 
eval image delete [image names]
31 
canvas .c -highlightthickness 2
32 
pack .c
33 
update
34 
test image-1.1 {Tk_ImageCmd procedure, "create" option} {
35 
    list [catch image msg] $msg
36 
} {1 {wrong # args: should be "image option ?args?"}}
37 
test image-1.2 {Tk_ImageCmd procedure, "create" option} {
38 
    list [catch {image gorp} msg] $msg
39 
} {1 {bad option "gorp": must be create, delete, height, names, type, types, or width}}
40 
test image-1.3 {Tk_ImageCmd procedure, "create" option} {
41 
    list [catch {image create} msg] $msg
42 
} {1 {wrong # args: should be "image create type ?name? ?options?"}}
43 
test image-1.4 {Tk_ImageCmd procedure, "create" option} {
44 
    list [catch {image c bad_type} msg] $msg
45 
} {1 {image type "bad_type" doesn't exist}}
46 
test image-1.5 {Tk_ImageCmd procedure, "create" option} {
47 
    list [image create test myimage] [image names]
48 
} {myimage myimage}
49 
test image-1.6 {Tk_ImageCmd procedure, "create" option} {
50 
    scan [image create test] image%d first
51 
    image create test myimage
52 
    scan [image create test -variable x] image%d second
53 
    expr $second-$first
54 
} {1}
55 
test image-1.7 {Tk_ImageCmd procedure, "create" option} {
56 
    image delete myimage
57 
    image create test myimage -variable x
58 
    .c create image 100 50 -image myimage
59 
    .c create image 100 150 -image myimage
60 
    update
61 
    set x {}
62 
    image create test myimage -variable x
63 
    update
64 
    set x
65 
} {{myimage free} {myimage free} {myimage delete} {myimage get} {myimage get} {myimage display 0 0 30 15 30 30} {myimage display 0 0 30 15 30 130}}
66 
test image-1.8 {Tk_ImageCmd procedure, "create" option} {
67 
    .c delete all
68 
    image create test myimage -variable x
69 
    .c create image 100 50 -image myimage
70 
    .c create image 100 150 -image myimage
71 
    image delete myimage
72 
    update
73 
    set x {}
74 
    image create test myimage -variable x
75 
    update
76 
    set x
77 
} {{myimage get} {myimage get} {myimage display 0 0 30 15 30 30} {myimage display 0 0 30 15 30 130}}
78 
test image-1.9 {Tk_ImageCmd procedure, "create" option} {
79 
    .c delete all
80 
    eval image delete [image names]
81 
    list [catch {image create test -badName foo} msg] $msg [image names]
82 
} {1 {bad option name "-badName"} {}}
83 
 
84 
test image-2.1 {Tk_ImageCmd procedure, "delete" option} {
85 
    list [catch {image delete} msg] $msg
86 
} {0 {}}
87 
test image-2.2 {Tk_ImageCmd procedure, "delete" option} {
88 
    .c delete all
89 
    eval image delete [image names]
90 
    image create test myimage
91 
    image create test img2
92 
    set result {}
93 
    lappend result [lsort [image names]]
94 
    image d myimage img2
95 
    lappend result [image names]
96 
} {{img2 myimage} {}}
97 
test image-2.3 {Tk_ImageCmd procedure, "delete" option} {
98 
    .c delete all
99 
    eval image delete [image names]
100 
    image create test myimage
101 
    image create test img2
102 
    list [catch {image delete myimage gorp img2} msg] $msg [image names]
103 
} {1 {image "gorp" doesn't exist} img2}
104 
 
105 
test image-3.1 {Tk_ImageCmd procedure, "height" option} {
106 
    list [catch {image height} msg] $msg
107 
} {1 {wrong # args: should be "image height name"}}
108 
test image-3.2 {Tk_ImageCmd procedure, "height" option} {
109 
    list [catch {image height a b} msg] $msg
110 
} {1 {wrong # args: should be "image height name"}}
111 
test image-3.3 {Tk_ImageCmd procedure, "height" option} {
112 
    list [catch {image height foo} msg] $msg
113 
} {1 {image "foo" doesn't exist}}
114 
test image-3.4 {Tk_ImageCmd procedure, "height" option} {
115 
    image create test myimage
116 
    set x [image h myimage]
117 
    myimage changed 0 0 0 0 60 50
118 
    list $x [image height myimage]
119 
} {15 50}
120 
 
121 
test image-4.1 {Tk_ImageCmd procedure, "names" option} {
122 
    list [catch {image names x} msg] $msg
123 
} {1 {wrong # args: should be "image names"}}
124 
test image-4.2 {Tk_ImageCmd procedure, "names" option} {
125 
    .c delete all
126 
    eval image delete [image names]
127 
    image create test myimage
128 
    image create test img2
129 
    image create test 24613
130 
    lsort [image names]
131 
} {24613 img2 myimage}
132 
test image-4.3 {Tk_ImageCmd procedure, "names" option} {
133 
    .c delete all
134 
    eval image delete [image names]
135 
    lsort [image names]
136 
} {}
137 
 
138 
test image-5.1 {Tk_ImageCmd procedure, "type" option} {
139 
    list [catch {image type} msg] $msg
140 
} {1 {wrong # args: should be "image type name"}}
141 
test image-5.2 {Tk_ImageCmd procedure, "type" option} {
142 
    list [catch {image type a b} msg] $msg
143 
} {1 {wrong # args: should be "image type name"}}
144 
test image-5.3 {Tk_ImageCmd procedure, "type" option} {
145 
    list [catch {image type foo} msg] $msg
146 
} {1 {image "foo" doesn't exist}}
147 
test image-5.4 {Tk_ImageCmd procedure, "type" option} {
148 
    image create test myimage
149 
    image type myimage
150 
} {test}
151 
test image-5.5 {Tk_ImageCmd procedure, "type" option} {
152 
    image create test myimage
153 
    .c create image 50 50 -image myimage
154 
    image delete myimage
155 
    image type myimage
156 
} {}
157 
 
158 
test image-6.1 {Tk_ImageCmd procedure, "types" option} {
159 
    list [catch {image types x} msg] $msg
160 
} {1 {wrong # args: should be "image types"}}
161 
test image-6.2 {Tk_ImageCmd procedure, "types" option} {
162 
    lsort [image types]
163 
} {bitmap photo test}
164 
 
165 
test image-7.1 {Tk_ImageCmd procedure, "width" option} {
166 
    list [catch {image width} msg] $msg
167 
} {1 {wrong # args: should be "image width name"}}
168 
test image-7.2 {Tk_ImageCmd procedure, "width" option} {
169 
    list [catch {image width a b} msg] $msg
170 
} {1 {wrong # args: should be "image width name"}}
171 
test image-7.3 {Tk_ImageCmd procedure, "width" option} {
172 
    list [catch {image width foo} msg] $msg
173 
} {1 {image "foo" doesn't exist}}
174 
test image-7.4 {Tk_ImageCmd procedure, "width" option} {
175 
    image create test myimage
176 
    set x [image w myimage]
177 
    myimage changed 0 0 0 0 60 50
178 
    list $x [image width myimage]
179 
} {30 60}
180 
 
181 
test image-8.1 {Tk_ImageChanged procedure} {
182 
    .c delete all
183 
    eval image delete [image names]
184 
    image create test foo -variable x
185 
    .c create image 50 50 -image foo
186 
    update
187 
    set x {}
188 
    foo changed 5 6 7 8 30 15
189 
    update
190 
    set x
191 
} {{foo display 5 6 7 8 30 30}}
192 
test image-8.2 {Tk_ImageChanged procedure} {
193 
    .c delete all
194 
    eval image delete [image names]
195 
    image create test foo -variable x
196 
    .c create image 50 50 -image foo
197 
    .c create image 90 100 -image foo
198 
    update
199 
    set x {}
200 
    foo changed 5 6 7 8 30 15
201 
    update
202 
    set x
203 
} {{foo display 5 6 25 9 30 30} {foo display 0 0 12 14 65 74}}
204 
 
205 
test image-9.1 {Tk_GetImage procedure} {
206 
    list [catch {.c create image 100 10 -image bad_name} msg] $msg
207 
} {1 {image "bad_name" doesn't exist}}
208 
test image-9.2 {Tk_GetImage procedure} {
209 
    image create test mytest
210 
    catch {destroy .l}
211 
    label .l -image mytest
212 
    image delete  mytest
213 
    set result [list [catch {label .l2 -image mytest} msg] $msg]
214 
    destroy .l
215 
    set result
216 
} {1 {image "mytest" doesn't exist}}
217 
 
218 
test image-10.1 {Tk_FreeImage procedure} {
219 
    .c delete all
220 
    eval image delete [image names]
221 
    image create test foo -variable x
222 
    .c create image 50 50 -image foo -tags i1
223 
    .c create image 90 100 -image foo -tags i2
224 
    pack forget .c
225 
    update
226 
    set x {}
227 
    .c delete i1
228 
    pack .c
229 
    update
230 
    list [image names] $x
231 
} {foo {{foo free} {foo display 0 0 30 15 103 121}}}
232 
test image-10.2 {Tk_FreeImage procedure} {
233 
    .c delete all
234 
    eval image delete [image names]
235 
    image create test foo -variable x
236 
    .c create image 50 50 -image foo -tags i1
237 
    image delete foo
238 
    update
239 
    set names [image names]
240 
    set x {}
241 
    .c delete i1
242 
    pack forget .c
243 
    pack .c
244 
    update
245 
    list $names [image names] $x
246 
} {foo {} {}}
247 
 
248 
# Non-portable, apparently due to differences in rounding:
249 
 
250 
test image-11.1 {Tk_RedrawImage procedure, redisplay area clipping} \
251 
        {nonPortable} {
252 
    .c delete all
253 
    eval image delete [image names]
254 
    image create test foo -variable x
255 
    .c create image 50 60 -image foo -tags i1 -anchor nw
256 
    update
257 
    .c create rectangle 30 40 55 65 -width 0 -fill black -outline {}
258 
    set x {}
259 
    update
260 
    set x
261 
} {{foo display 0 0 5 5 50 50}}
262 
test image-11.2 {Tk_RedrawImage procedure, redisplay area clipping} \
263 
        {nonPortable} {
264 
    .c delete all
265 
    eval image delete [image names]
266 
    image create test foo -variable x
267 
    .c create image 50 60 -image foo -tags i1 -anchor nw
268 
    update
269 
    .c create rectangle 60 40 100 65 -width 0 -fill black -outline {}
270 
    set x {}
271 
    update
272 
    set x
273 
} {{foo display 10 0 20 5 30 50}}
274 
test image-11.3 {Tk_RedrawImage procedure, redisplay area clipping} \
275 
        {nonPortable} {
276 
    .c delete all
277 
    eval image delete [image names]
278 
    image create test foo -variable x
279 
    .c create image 50 60 -image foo -tags i1 -anchor nw
280 
    update
281 
    .c create rectangle 60 70 100 200 -width 0 -fill black -outline {}
282 
    set x {}
283 
    update
284 
    set x
285 
} {{foo display 10 10 20 5 30 30}}
286 
test image-11.4 {Tk_RedrawImage procedure, redisplay area clipping} \
287 
        {nonPortable} {
288 
    .c delete all
289 
    eval image delete [image names]
290 
    image create test foo -variable x
291 
    .c create image 50 60 -image foo -tags i1 -anchor nw
292 
    update
293 
    .c create rectangle 30 70 55 200 -width 0 -fill black -outline {}
294 
    set x {}
295 
    update
296 
    set x
297 
} {{foo display 0 10 5 5 50 30}}
298 
test image-11.5 {Tk_RedrawImage procedure, redisplay area clipping} \
299 
        {nonPortable} {
300 
    .c delete all
301 
    eval image delete [image names]
302 
    image create test foo -variable x
303 
    .c create image 50 60 -image foo -tags i1 -anchor nw
304 
    update
305 
    .c create rectangle 10 20 120 130 -width 0 -fill black -outline {}
306 
    set x {}
307 
    update
308 
    set x
309 
} {{foo display 0 0 30 15 70 70}}
310 
test image-11.6 {Tk_RedrawImage procedure, redisplay area clipping} \
311 
        {nonPortable} {
312 
    .c delete all
313 
    eval image delete [image names]
314 
    image create test foo -variable x
315 
    .c create image 50 60 -image foo -tags i1 -anchor nw
316 
    update
317 
    .c create rectangle 55 65 75 70 -width 0 -fill black -outline {}
318 
    set x {}
319 
    update
320 
    set x
321 
} {{foo display 5 5 20 5 30 30}}
322 
 
323 
test image-12.1 {Tk_SizeOfImage procedure} {
324 
    eval image delete [image names]
325 
    image create test foo -variable x
326 
    set result [list [image width foo] [image height foo]]
327 
    foo changed 0 0 0 0 85 60
328 
    lappend result [image width foo] [image height foo]
329 
} {30 15 85 60}
330 
 
331 
test image-12.2 {DeleteImage procedure} {
332 
    .c delete all
333 
    eval image delete [image names]
334 
    image create test foo -variable x
335 
    .c create image 50 50 -image foo -tags i1
336 
    .c create image 90 100 -image foo -tags i2
337 
    set x {}
338 
    image delete foo
339 
    lappend x | [image names] |
340 
    image delete foo
341 
    lappend x | [image names] |
342 
} {{foo free} {foo free} {foo delete} | foo | | foo |}
343 
 
344 
catch {image delete hidden}
345 
set l [image names]
346 
set h [interp hidden]
347 
 
348 
test image-13.1 {image command vs hidden commands} {
349 
    catch {image delete hidden}
350 
    image create photo hidden
351 
    interp hide {} hidden
352 
    image delete hidden
353 
    list [image names] [interp hidden]
354 
} [list $l $h]
355 
 
356 
destroy .c
357 
eval image delete [image names]

powered by: WebSVN 2.1.0

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