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