1# 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# Copyright (c) 1998-1999 by Scriptics Corporation. 8# All rights reserved. 9# 10# RCS: @(#) $Id$ 11 12package require tcltest 2.1 13eval tcltest::configure $argv 14tcltest::loadTestedCommands 15namespace import -force ::tk::test::loadTkCommand 16 17eval image delete [image names] 18canvas .c -highlightthickness 2 19pack .c 20update 21test image-1.1 {Tk_ImageCmd procedure, "create" option} { 22 list [catch image msg] $msg 23} {1 {wrong # args: should be "image option ?args?"}} 24test image-1.2 {Tk_ImageCmd procedure, "create" option} { 25 list [catch {image gorp} msg] $msg 26} {1 {bad option "gorp": must be create, delete, height, inuse, names, type, types, or width}} 27test image-1.3 {Tk_ImageCmd procedure, "create" option} { 28 list [catch {image create} msg] $msg 29} {1 {wrong # args: should be "image create type ?name? ?options?"}} 30test image-1.4 {Tk_ImageCmd procedure, "create" option} { 31 list [catch {image c bad_type} msg] $msg 32} {1 {image type "bad_type" doesn't exist}} 33test image-1.5 {Tk_ImageCmd procedure, "create" option} testImageType { 34 list [image create test myimage] [image names] 35} {myimage myimage} 36test image-1.6 {Tk_ImageCmd procedure, "create" option} testImageType { 37 scan [image create test] image%d first 38 image create test myimage 39 scan [image create test -variable x] image%d second 40 expr $second-$first 41} {1} 42test image-1.7 {Tk_ImageCmd procedure, "create" option} testImageType { 43 image delete myimage 44 image create test myimage -variable x 45 .c create image 100 50 -image myimage 46 .c create image 100 150 -image myimage 47 update 48 set x {} 49 image create test myimage -variable x 50 update 51 set x 52} {{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}} 53test image-1.8 {Tk_ImageCmd procedure, "create" option} testImageType { 54 .c delete all 55 image create test myimage -variable x 56 .c create image 100 50 -image myimage 57 .c create image 100 150 -image myimage 58 image delete myimage 59 update 60 set x {} 61 image create test myimage -variable x 62 update 63 set x 64} {{myimage get} {myimage get} {myimage display 0 0 30 15 30 30} {myimage display 0 0 30 15 30 130}} 65test image-1.9 {Tk_ImageCmd procedure, "create" option} testImageType { 66 .c delete all 67 eval image delete [image names] 68 list [catch {image create test -badName foo} msg] $msg [image names] 69} {1 {bad option name "-badName"} {}} 70test image-1.10 {Tk_ImageCmd procedure, "create" option with same name as main window} { 71 set code [loadTkCommand] 72 append code { 73 update 74 puts [list [catch {image create photo .} msg] $msg] 75 exit 76 } 77 set script [makeFile $code script] 78 set x [list [catch {exec [interpreter] <$script} msg] $msg] 79 removeFile script 80 set x 81} {0 {1 {images may not be named the same as the main window}}} 82test image-1.11 {Tk_ImageCmd procedure, "create" option with same name as main window after renaming} { 83 set code [loadTkCommand] 84 append code { 85 update 86 puts [list [catch {rename . foo;image create photo foo} msg] $msg] 87 exit 88 } 89 set script [makeFile $code script] 90 set x [list [catch {exec [interpreter] <$script} msg] $msg] 91 removeFile script 92 set x 93} {0 {1 {images may not be named the same as the main window}}} 94test image-1.12 {Tk_ImageCmd, "create" option: do not generated command name in use} -setup { 95 set i [image create bitmap] 96 regexp {^image(\d+)$} $i -> serial 97 incr serial 98 proc image$serial {} {return works} 99 set j [image create bitmap] 100} -body { 101 image$serial 102} -cleanup { 103 rename image$serial {} 104 image delete $i $j 105} -result works 106 107test image-2.1 {Tk_ImageCmd procedure, "delete" option} { 108 list [catch {image delete} msg] $msg 109} {0 {}} 110test image-2.2 {Tk_ImageCmd procedure, "delete" option} testImageType { 111 .c delete all 112 eval image delete [image names] 113 image create test myimage 114 image create test img2 115 set result {} 116 lappend result [lsort [image names]] 117 image d myimage img2 118 lappend result [image names] 119} {{img2 myimage} {}} 120test image-2.3 {Tk_ImageCmd procedure, "delete" option} testImageType { 121 .c delete all 122 eval image delete [image names] 123 image create test myimage 124 image create test img2 125 list [catch {image delete myimage gorp img2} msg] $msg [image names] 126} {1 {image "gorp" doesn't exist} img2} 127 128test image-3.1 {Tk_ImageCmd procedure, "height" option} { 129 list [catch {image height} msg] $msg 130} {1 {wrong # args: should be "image height name"}} 131test image-3.2 {Tk_ImageCmd procedure, "height" option} { 132 list [catch {image height a b} msg] $msg 133} {1 {wrong # args: should be "image height name"}} 134test image-3.3 {Tk_ImageCmd procedure, "height" option} { 135 list [catch {image height foo} msg] $msg 136} {1 {image "foo" doesn't exist}} 137test image-3.4 {Tk_ImageCmd procedure, "height" option} testImageType { 138 image create test myimage 139 set x [image h myimage] 140 myimage changed 0 0 0 0 60 50 141 list $x [image height myimage] 142} {15 50} 143 144test image-4.1 {Tk_ImageCmd procedure, "names" option} { 145 list [catch {image names x} msg] $msg 146} {1 {wrong # args: should be "image names"}} 147test image-4.2 {Tk_ImageCmd procedure, "names" option} testImageType { 148 .c delete all 149 eval image delete [image names] 150 image create test myimage 151 image create test img2 152 image create test 24613 153 lsort [image names] 154} {24613 img2 myimage} 155test image-4.3 {Tk_ImageCmd procedure, "names" option} { 156 .c delete all 157 eval image delete [image names] 158 lsort [image names] 159} {} 160 161test image-5.1 {Tk_ImageCmd procedure, "type" option} { 162 list [catch {image type} msg] $msg 163} {1 {wrong # args: should be "image type name"}} 164test image-5.2 {Tk_ImageCmd procedure, "type" option} { 165 list [catch {image type a b} msg] $msg 166} {1 {wrong # args: should be "image type name"}} 167test image-5.3 {Tk_ImageCmd procedure, "type" option} { 168 list [catch {image type foo} msg] $msg 169} {1 {image "foo" doesn't exist}} 170test image-5.4 {Tk_ImageCmd procedure, "type" option} testImageType { 171 image create test myimage 172 image type myimage 173} {test} 174test image-5.5 {Tk_ImageCmd procedure, "type" option} testImageType { 175 image create test myimage 176 .c create image 50 50 -image myimage 177 image delete myimage 178 list [catch {image type myimage} msg] $msg 179} {1 {image "myimage" doesn't exist}} 180test image-5.6 {Tk_ImageCmd procedure, "type" option} testOldImageType { 181 image create oldtest myimage 182 image type myimage 183} {oldtest} 184test image-5.7 {Tk_ImageCmd procedure, "type" option} testOldImageType { 185 image create oldtest myimage 186 .c create image 50 50 -image myimage 187 image delete myimage 188 list [catch {image type myimage} msg] $msg 189} {1 {image "myimage" doesn't exist}} 190 191test image-6.1 {Tk_ImageCmd procedure, "types" option} { 192 list [catch {image types x} msg] $msg 193} {1 {wrong # args: should be "image types"}} 194test image-6.2 {Tk_ImageCmd procedure, "types" option} testImageType { 195 lsort [image types] 196} {bitmap oldtest photo test} 197 198test image-7.1 {Tk_ImageCmd procedure, "width" option} { 199 list [catch {image width} msg] $msg 200} {1 {wrong # args: should be "image width name"}} 201test image-7.2 {Tk_ImageCmd procedure, "width" option} { 202 list [catch {image width a b} msg] $msg 203} {1 {wrong # args: should be "image width name"}} 204test image-7.3 {Tk_ImageCmd procedure, "width" option} { 205 list [catch {image width foo} msg] $msg 206} {1 {image "foo" doesn't exist}} 207test image-7.4 {Tk_ImageCmd procedure, "width" option} testImageType { 208 image create test myimage 209 set x [image w myimage] 210 myimage changed 0 0 0 0 60 50 211 list $x [image width myimage] 212} {30 60} 213 214test image-8.1 {Tk_ImageCmd procedure, "inuse" option} testImageType { 215 catch {image delete myimage2} 216 image create test myimage2 217 set res {} 218 lappend res [image inuse myimage2] 219 catch {destroy .b} 220 button .b -image myimage2 221 lappend res [image inuse myimage2] 222 catch {destroy .b} 223 image delete myimage2 224 set res 225} [list 0 1] 226 227 228test image-9.1 {Tk_ImageChanged procedure} testImageType { 229 .c delete all 230 eval image delete [image names] 231 image create test foo -variable x 232 .c create image 50 50 -image foo 233 update 234 set x {} 235 foo changed 5 6 7 8 30 15 236 update 237 set x 238} {{foo display 5 6 7 8 30 30}} 239test image-9.2 {Tk_ImageChanged procedure} testImageType { 240 .c delete all 241 eval image delete [image names] 242 image create test foo -variable x 243 .c create image 50 50 -image foo 244 .c create image 90 100 -image foo 245 update 246 set x {} 247 foo changed 5 6 7 8 30 15 248 update 249 set x 250} {{foo display 5 6 25 9 30 30} {foo display 0 0 12 14 65 74}} 251 252test image-10.1 {Tk_GetImage procedure} { 253 list [catch {.c create image 100 10 -image bad_name} msg] $msg 254} {1 {image "bad_name" doesn't exist}} 255test image-10.2 {Tk_GetImage procedure} testImageType { 256 image create test mytest 257 catch {destroy .l} 258 label .l -image mytest 259 image delete mytest 260 set result [list [catch {label .l2 -image mytest} msg] $msg] 261 destroy .l 262 set result 263} {1 {image "mytest" doesn't exist}} 264 265test image-11.1 {Tk_FreeImage procedure} testImageType { 266 .c delete all 267 eval image delete [image names] 268 image create test foo -variable x 269 .c create image 50 50 -image foo -tags i1 270 .c create image 90 100 -image foo -tags i2 271 pack forget .c 272 update 273 set x {} 274 .c delete i1 275 pack .c 276 update 277 list [image names] $x 278} {foo {{foo free} {foo display 0 0 30 15 103 121}}} 279test image-11.2 {Tk_FreeImage procedure} testImageType { 280 .c delete all 281 eval image delete [image names] 282 image create test foo -variable x 283 .c create image 50 50 -image foo -tags i1 284 set names [image names] 285 image delete foo 286 update 287 set names2 [image names] 288 set x {} 289 .c delete i1 290 pack forget .c 291 pack .c 292 update 293 list $names $names2 [image names] $x 294} {foo {} {} {}} 295 296# Non-portable, apparently due to differences in rounding: 297 298test image-12.1 {Tk_RedrawImage procedure, redisplay area clipping} \ 299 {testImageType 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 30 40 55 65 -width 0 -fill black -outline {} 306 set x {} 307 update 308 set x 309} {{foo display 0 0 5 5 50 50}} 310test image-12.2 {Tk_RedrawImage procedure, redisplay area clipping} \ 311 {testImageType 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 60 40 100 65 -width 0 -fill black -outline {} 318 set x {} 319 update 320 set x 321} {{foo display 10 0 20 5 30 50}} 322test image-12.3 {Tk_RedrawImage procedure, redisplay area clipping} \ 323 {testImageType nonPortable} { 324 .c delete all 325 eval image delete [image names] 326 image create test foo -variable x 327 .c create image 50 60 -image foo -tags i1 -anchor nw 328 update 329 .c create rectangle 60 70 100 200 -width 0 -fill black -outline {} 330 set x {} 331 update 332 set x 333} {{foo display 10 10 20 5 30 30}} 334test image-12.4 {Tk_RedrawImage procedure, redisplay area clipping} \ 335 {testImageType nonPortable} { 336 .c delete all 337 eval image delete [image names] 338 image create test foo -variable x 339 .c create image 50 60 -image foo -tags i1 -anchor nw 340 update 341 .c create rectangle 30 70 55 200 -width 0 -fill black -outline {} 342 set x {} 343 update 344 set x 345} {{foo display 0 10 5 5 50 30}} 346test image-12.5 {Tk_RedrawImage procedure, redisplay area clipping} \ 347 {testImageType nonPortable} { 348 .c delete all 349 eval image delete [image names] 350 image create test foo -variable x 351 .c create image 50 60 -image foo -tags i1 -anchor nw 352 update 353 .c create rectangle 10 20 120 130 -width 0 -fill black -outline {} 354 set x {} 355 update 356 set x 357} {{foo display 0 0 30 15 70 70}} 358test image-12.6 {Tk_RedrawImage procedure, redisplay area clipping} \ 359 {testImageType nonPortable} { 360 .c delete all 361 eval image delete [image names] 362 image create test foo -variable x 363 .c create image 50 60 -image foo -tags i1 -anchor nw 364 update 365 .c create rectangle 55 65 75 70 -width 0 -fill black -outline {} 366 set x {} 367 update 368 set x 369} {{foo display 5 5 20 5 30 30}} 370 371test image-13.1 {Tk_SizeOfImage procedure} testImageType { 372 eval image delete [image names] 373 image create test foo -variable x 374 set result [list [image width foo] [image height foo]] 375 foo changed 0 0 0 0 85 60 376 lappend result [image width foo] [image height foo] 377} {30 15 85 60} 378 379test image-13.2 {DeleteImage procedure} testImageType { 380 .c delete all 381 eval image delete [image names] 382 image create test foo -variable x 383 .c create image 50 50 -image foo -tags i1 384 .c create image 90 100 -image foo -tags i2 385 set x {} 386 image delete foo 387 lappend x | [image names] | [catch {image delete foo} msg] | $msg | [image names] | 388} {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |} 389 390test image-13.3 {Tk_SizeOfImage procedure} testOldImageType { 391 eval image delete [image names] 392 image create oldtest foo -variable x 393 set result [list [image width foo] [image height foo]] 394 foo changed 0 0 0 0 85 60 395 lappend result [image width foo] [image height foo] 396} {30 15 85 60} 397 398test image-13.4 {DeleteImage procedure} testOldImageType { 399 .c delete all 400 eval image delete [image names] 401 image create oldtest foo -variable x 402 .c create image 50 50 -image foo -tags i1 403 .c create image 90 100 -image foo -tags i2 404 set x {} 405 image delete foo 406 lappend x | [image names] | [catch {image delete foo} msg] | $msg | [image names] | 407} {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |} 408 409 410catch {image delete hidden} 411set l [image names] 412set h [interp hidden] 413 414test image-14.1 {image command vs hidden commands} { 415 catch {image delete hidden} 416 image create photo hidden 417 interp hide {} hidden 418 image delete hidden 419 list [image names] [interp hidden] 420} [list $l $h] 421 422eval image delete [image names] 423test image-15.1 {deleting image does not make widgets forget about it} { 424 .c delete all 425 image create photo foo -width 10 -height 10 426 .c create image 10 10 -image foo -tags i1 -anchor nw 427 update 428 set x [.c bbox i1] 429 lappend x [image names] 430 image delete foo 431 lappend x [image names] 432 image create photo foo -width 20 -height 20 433 lappend x [.c bbox i1] [image names] 434} {10 10 20 20 foo {} {10 10 30 30} foo} 435 436destroy .c 437eval image delete [image names] 438 439# cleanup 440cleanupTests 441return 442