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 © 1994 The Regents of the University of California. 6# Copyright © 1994 Sun Microsystems, Inc. 7# Copyright © 1998-1999 Scriptics Corporation. 8# All rights reserved. 9 10package require tcltest 2.2 11namespace import ::tcltest::* 12eval tcltest::configure $argv 13tcltest::loadTestedCommands 14 15imageInit 16 17# Canvas used in some tests in the whole file 18canvas .c -highlightthickness 2 19pack .c 20update 21 22 23test image-1.1 {Tk_ImageCmd procedure, "create" option} -body { 24 image 25} -returnCodes error -result {wrong # args: should be "image option ?args?"} 26test image-1.2 {Tk_ImageCmd procedure, "create" option} -body { 27 image gorp 28} -returnCodes error -result {bad option "gorp": must be create, delete, height, inuse, names, type, types, or width} 29test image-1.3 {Tk_ImageCmd procedure, "create" option} -body { 30 image create 31} -returnCodes error -result {wrong # args: should be "image create type ?name? ?-option value ...?"} 32test image-1.4 {Tk_ImageCmd procedure, "create" option} -body { 33 image c bad_type 34} -returnCodes error -result {image type "bad_type" doesn't exist} 35test image-1.5 {Tk_ImageCmd procedure, "create" option} -constraints { 36 testImageType 37} -body { 38 list [image create test myimage] [imageNames] 39} -cleanup { 40 imageCleanup 41} -result {myimage myimage} 42test image-1.6 {Tk_ImageCmd procedure, "create" option} -constraints { 43 testImageType 44} -setup { 45 imageCleanup 46} -body { 47 scan [image create test] image%d first 48 image create test myimage 49 scan [image create test -variable x] image%d second 50 expr {$second-$first} 51} -cleanup { 52 imageCleanup 53} -result 1 54 55test image-1.7 {Tk_ImageCmd procedure, "create" option} -constraints { 56 testImageType 57} -setup { 58 imageCleanup 59} -body { 60 image create test myimage -variable x 61 .c create image 100 50 -image myimage 62 .c create image 100 150 -image myimage 63 update 64 set x {} 65 set timer [after 500 {lappend x "timed out"}] 66 image create test myimage -variable x 67 update idletasks 68 update 69 # On MacOS we need to wait for the test image display procedure to run. 70 while {"timed out" ni $x && [lindex $x end 1] ne "display"} { 71 vwait x 72 } 73 after cancel timer 74 if {[lindex $x end] eq "timed out"} { 75 return [lreplace $x end end] 76 } 77 return $x 78} -cleanup { 79 imageCleanup 80} -result {{myimage free} {myimage free} {myimage delete} {myimage get} {myimage get} {myimage display 0 0 30 15} {myimage display 0 0 30 15}} 81test image-1.8 {Tk_ImageCmd procedure, "create" option} -constraints { 82 testImageType 83} -setup { 84 .c delete all 85 imageCleanup 86} -body { 87 image create test myimage -variable x 88 .c create image 100 50 -image myimage 89 .c create image 100 150 -image myimage 90 image delete myimage 91 update 92 set x {} 93 set timer [after 500 {lappend x "timed out"}] 94 image create test myimage -variable x 95 vwait x 96 after cancel $timer 97 return $x 98} -cleanup { 99 .c delete all 100 imageCleanup 101} -result {{myimage get} {myimage get} {myimage display 0 0 30 15} {myimage display 0 0 30 15}} 102test image-1.9 {Tk_ImageCmd procedure, "create" option} -constraints { 103 testImageType 104} -body { 105 image create test -badName foo 106} -returnCodes error -result {bad option name "-badName"} 107test image-1.10 {Tk_ImageCmd procedure, "create" option} -constraints { 108 testImageType 109} -body { 110 catch {image create test -badName foo} 111 imageNames 112} -result {} 113test image-1.11 {Tk_ImageCmd procedure, "create" option with same name as main window} -body { 114 set code [loadTkCommand] 115 append code { 116 update 117 puts [list [catch {image create photo .} msg] $msg] 118 exit 119 } 120 set script [makeFile $code script] 121 exec [interpreter] <$script 122} -cleanup { 123 removeFile script 124} -result {1 {images may not be named the same as the main window}} 125test image-1.12 {Tk_ImageCmd procedure, "create" option with same name as main window after renaming} -body { 126 set code [loadTkCommand] 127 append code { 128 update 129 puts [list [catch {rename . foo;image create photo foo} msg] $msg] 130 exit 131 } 132 set script [makeFile $code script] 133 exec [interpreter] <$script 134} -cleanup { 135 removeFile script 136} -result {1 {images may not be named the same as the main window}} 137test image-1.13 {Tk_ImageCmd, "create" option: do not generated command name in use} -setup { 138 .c delete all 139 imageCleanup 140} -body { 141 set i [image create bitmap] 142 regexp {^image(\d+)$} $i -> serial 143 incr serial 144 proc image$serial {} {return works} 145 set j [image create bitmap] 146 147 image$serial 148} -cleanup { 149 rename image$serial {} 150 image delete $i $j 151} -result works 152 153test image-2.1 {Tk_ImageCmd procedure, "delete" option} -body { 154 image delete 155} -result {} 156test image-2.2 {Tk_ImageCmd procedure, "delete" option} -constraints { 157 testImageType 158} -setup { 159 imageCleanup 160 set result {} 161} -body { 162 image create test myimage 163 image create test img2 164 lappend result [lsort [imageNames]] 165 image d myimage img2 166 lappend result [imageNames] 167} -cleanup { 168 imageCleanup 169} -result {{img2 myimage} {}} 170test image-2.3 {Tk_ImageCmd procedure, "delete" option} -constraints { 171 testImageType 172} -setup { 173 imageCleanup 174} -body { 175 image create test myimage 176 image create test img2 177 image delete myimage gorp img2 178} -cleanup { 179 imageCleanup 180} -returnCodes error -result {image "gorp" doesn't exist} 181test image-2.4 {Tk_ImageCmd procedure, "delete" option} -constraints { 182 testImageType 183} -setup { 184 imageCleanup 185} -body { 186 image create test myimage 187 image create test img2 188 catch {image delete myimage gorp img2} 189 imageNames 190} -cleanup { 191 imageCleanup 192} -result {img2} 193 194 195test image-3.1 {Tk_ImageCmd procedure, "height" option} -body { 196 image height 197} -returnCodes error -result {wrong # args: should be "image height name"} 198test image-3.2 {Tk_ImageCmd procedure, "height" option} -body { 199 image height a b 200} -returnCodes error -result {wrong # args: should be "image height name"} 201test image-3.3 {Tk_ImageCmd procedure, "height" option} -body { 202 image height foo 203} -returnCodes error -result {image "foo" doesn't exist} 204test image-3.4 {Tk_ImageCmd procedure, "height" option} -constraints { 205 testImageType 206} -setup { 207 imageCleanup 208} -body { 209 image create test myimage 210 set x [image h myimage] 211 myimage changed 0 0 0 0 60 50 212 list $x [image height myimage] 213} -cleanup { 214 imageCleanup 215} -result {15 50} 216 217 218test image-4.1 {Tk_ImageCmd procedure, "names" option} -body { 219 image names x 220} -returnCodes error -result {wrong # args: should be "image names"} 221test image-4.2 {Tk_ImageCmd procedure, "names" option} -constraints { 222 testImageType 223} -setup { 224 catch {interp delete testinterp} 225} -body { 226 interp create testinterp 227 load {} Tk testinterp 228 interp eval testinterp { 229 image delete {*}[image names] 230 image create test myimage 231 image create test img2 232 image create test 24613 233 lsort [image names] 234 } 235} -cleanup { 236 interp delete testinterp 237} -result {24613 img2 myimage} 238test image-4.3 {Tk_ImageCmd procedure, "names" option} -setup { 239 catch {interp delete testinterp} 240} -body { 241 interp create testinterp 242 load {} Tk testinterp 243 interp eval testinterp { 244 image delete {*}[image names] 245 eval image delete [image names] [image names] 246 lsort [image names] 247 } 248} -cleanup { 249 interp delete testinterp 250} -result {} 251 252 253test image-5.1 {Tk_ImageCmd procedure, "type" option} -body { 254 image type 255} -returnCodes error -result {wrong # args: should be "image type name"} 256test image-5.2 {Tk_ImageCmd procedure, "type" option} -body { 257 image type a b 258} -returnCodes error -result {wrong # args: should be "image type name"} 259test image-5.3 {Tk_ImageCmd procedure, "type" option} -body { 260 image type foo 261} -returnCodes error -result {image "foo" doesn't exist} 262 263test image-5.4 {Tk_ImageCmd procedure, "type" option} -constraints { 264 testImageType 265} -setup { 266 imageCleanup 267} -body { 268 image create test myimage 269 image type myimage 270} -cleanup { 271 imageCleanup 272} -result {test} 273test image-5.5 {Tk_ImageCmd procedure, "type" option} -constraints { 274 testImageType 275} -setup { 276 imageCleanup 277} -body { 278 image create test myimage 279 .c create image 50 50 -image myimage 280 image delete myimage 281 image type myimage 282} -cleanup { 283 imageCleanup 284} -returnCodes error -result {image "myimage" doesn't exist} 285test image-5.6 {Tk_ImageCmd procedure, "type" option} -constraints { 286 testOldImageType 287} -setup { 288 imageCleanup 289} -body { 290 image create oldtest myimage 291 image type myimage 292} -cleanup { 293 imageCleanup 294} -result {oldtest} 295test image-5.7 {Tk_ImageCmd procedure, "type" option} -constraints { 296 testOldImageType 297} -setup { 298 .c delete all 299 imageCleanup 300} -body { 301 image create oldtest myimage 302 .c create image 50 50 -image myimage 303 image delete myimage 304 image type myimage 305} -cleanup { 306 .c delete all 307 imageCleanup 308} -returnCodes error -result {image "myimage" doesn't exist} 309 310 311test image-6.1 {Tk_ImageCmd procedure, "types" option} -constraints { 312 testImageType 313} -body { 314 image types x 315} -returnCodes error -result {wrong # args: should be "image types"} 316test image-6.2 {Tk_ImageCmd procedure, "types" option} -body { 317 lsort [image types] 318} -match glob -result {bitmap*photo test} 319 320 321test image-7.1 {Tk_ImageCmd procedure, "width" option} -body { 322 image width 323} -returnCodes error -result {wrong # args: should be "image width name"} 324test image-7.2 {Tk_ImageCmd procedure, "width" option} -body { 325 image width a b 326} -returnCodes error -result {wrong # args: should be "image width name"} 327test image-7.3 {Tk_ImageCmd procedure, "width" option} -body { 328 image width foo 329} -returnCodes error -result {image "foo" doesn't exist} 330test image-7.4 {Tk_ImageCmd procedure, "width" option} -constraints { 331 testImageType 332} -setup { 333 imageCleanup 334} -body { 335 image create test myimage 336 set x [image w myimage] 337 myimage changed 0 0 0 0 60 50 338 list $x [image width myimage] 339} -cleanup { 340 imageCleanup 341} -result {30 60} 342 343 344test image-8.1 {Tk_ImageCmd procedure, "inuse" option} -constraints { 345 testImageType 346} -setup { 347 imageCleanup 348 set res {} 349 destroy .b 350} -body { 351 image create test myimage2 352 lappend res [image inuse myimage2] 353 button .b -image myimage2 354 lappend res [image inuse myimage2] 355} -cleanup { 356 imageCleanup 357 catch {destroy .b} 358} -result [list 0 1] 359 360test image-9.1 {Tk_ImageChanged procedure} -constraints testImageType -setup { 361 .c delete all 362 imageCleanup 363 update 364} -body { 365 image create test foo -variable x 366 .c create image 50 50 -image foo 367 update 368 set x {} 369 set timer [after 500 {lappend x "timed out"}] 370 foo changed 5 6 7 8 30 15 371 update idletasks 372 update 373 # On MacOS we need to wait for the test image display procedure to run. 374 while {"timed out" ni $x && [lindex $x end 1] ne "display"} { 375 vwait x 376 } 377 after cancel $timer 378 return $x 379} -cleanup { 380 .c delete all 381 imageCleanup 382} -result {{foo display 5 6 7 8}} 383 384test image-9.2 {Tk_ImageChanged procedure} -constraints testImageType -setup { 385 .c delete all 386 imageCleanup 387 update 388} -body { 389 image create test foo -variable x 390 .c create image 50 50 -image foo 391 .c create image 90 100 -image foo 392 update 393 set x {} 394 foo changed 5 6 7 8 30 15 395 set timer [after 500 {lappend x "timed out"}] 396 image create test myimage -variable x 397 vwait x 398 after cancel $timer 399 return $x 400} -cleanup { 401 .c delete all 402 imageCleanup 403} -result {{foo display 5 6 25 9} {foo display 0 0 12 14}} 404 405test image-10.1 {Tk_GetImage procedure} -setup { 406 imageCleanup 407} -body { 408 .c create image 100 10 -image bad_name 409} -cleanup { 410 imageCleanup 411} -returnCodes error -result {image "bad_name" doesn't exist} 412test image-10.2 {Tk_GetImage procedure} -constraints testImageType -setup { 413 destroy .l 414 imageCleanup 415} -body { 416 image create test mytest 417 label .l -image mytest 418 image delete mytest 419 label .l2 -image mytest 420} -cleanup { 421 destroy .l 422 imageCleanup 423} -returnCodes error -result {image "mytest" doesn't exist} 424 425 426test image-11.1 {Tk_FreeImage procedure} -constraints testImageType -setup { 427 .c delete all 428 imageCleanup 429} -body { 430 image create test foo -variable x 431 .c create image 50 50 -image foo -tags i1 432 .c create image 90 100 -image foo -tags i2 433 pack forget .c 434 update 435 set x {} 436 .c delete i1 437 set timer [after 500 {lappend x "timed out"}] 438 pack .c 439 vwait x 440 after cancel $timer 441 list [imageNames] $x 442} -cleanup { 443 .c delete all 444 imageCleanup 445} -result {foo {{foo free} {foo display 0 0 30 15}}} 446test image-11.2 {Tk_FreeImage procedure} -constraints testImageType -setup { 447 .c delete all 448 imageCleanup 449} -body { 450 image create test foo -variable x 451 .c create image 50 50 -image foo -tags i1 452 set names [imageNames] 453 image delete foo 454 update 455 set names2 [imageNames] 456 set x {} 457 .c delete i1 458 pack forget .c 459 pack .c 460 update 461 list $names $names2 [imageNames] $x 462} -cleanup { 463 .c delete all 464 imageCleanup 465} -result {foo {} {} {}} 466 467 468# Non-portable, apparently due to differences in rounding: 469test image-12.1 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { 470 testImageType nonPortable 471} -setup { 472 imageCleanup 473} -body { 474 image create test foo -variable x 475 .c create image 50 60 -image foo -tags i1 -anchor nw 476 update 477 .c create rectangle 30 40 55 65 -width 0 -fill black -outline {} 478 set x {} 479 update 480 return $x 481} -cleanup { 482 imageCleanup 483} -result {{foo display 0 0 5 5 50 50}} 484test image-12.2 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { 485 testImageType nonPortable 486} -setup { 487 imageCleanup 488} -body { 489 image create test foo -variable x 490 .c create image 50 60 -image foo -tags i1 -anchor nw 491 update 492 .c create rectangle 60 40 100 65 -width 0 -fill black -outline {} 493 set x {} 494 update 495 return $x 496} -cleanup { 497 imageCleanup 498} -result {{foo display 10 0 20 5 30 50}} 499test image-12.3 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { 500 testImageType nonPortable 501} -setup { 502 imageCleanup 503} -body { 504 image create test foo -variable x 505 .c create image 50 60 -image foo -tags i1 -anchor nw 506 update 507 .c create rectangle 60 70 100 200 -width 0 -fill black -outline {} 508 set x {} 509 update 510 return $x 511} -cleanup { 512 imageCleanup 513} -result {{foo display 10 10 20 5 30 30}} 514test image-12.4 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { 515 testImageType nonPortable 516} -setup { 517 imageCleanup 518} -body { 519 image create test foo -variable x 520 .c create image 50 60 -image foo -tags i1 -anchor nw 521 update 522 .c create rectangle 30 70 55 200 -width 0 -fill black -outline {} 523 set x {} 524 update 525 return $x 526} -cleanup { 527 imageCleanup 528} -result {{foo display 0 10 5 5 50 30}} 529test image-12.5 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { 530 testImageType nonPortable 531} -setup { 532 imageCleanup 533} -body { 534 image create test foo -variable x 535 .c create image 50 60 -image foo -tags i1 -anchor nw 536 update 537 .c create rectangle 10 20 120 130 -width 0 -fill black -outline {} 538 set x {} 539 update 540 return $x 541} -cleanup { 542 imageCleanup 543} -result {{foo display 0 0 30 15 70 70}} 544test image-12.6 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { 545 testImageType nonPortable 546} -setup { 547 imageCleanup 548} -body { 549 image create test foo -variable x 550 .c create image 50 60 -image foo -tags i1 -anchor nw 551 update 552 .c create rectangle 55 65 75 70 -width 0 -fill black -outline {} 553 set x {} 554 update 555 return $x 556} -cleanup { 557 imageCleanup 558} -result {{foo display 5 5 20 5 30 30}} 559 560 561test image-13.1 {Tk_SizeOfImage procedure} -constraints testImageType -setup { 562 imageCleanup 563} -body { 564 image create test foo -variable x 565 set result [list [image width foo] [image height foo]] 566 foo changed 0 0 0 0 85 60 567 lappend result [image width foo] [image height foo] 568} -cleanup { 569 imageCleanup 570} -result {30 15 85 60} 571 572test image-13.2 {DeleteImage procedure} -constraints testImageType -setup { 573 .c delete all 574 imageCleanup 575} -body { 576 image create test foo -variable x 577 .c create image 50 50 -image foo -tags i1 578 .c create image 90 100 -image foo -tags i2 579 set x {} 580 image delete foo 581 lappend x | [imageNames] | [catch {image delete foo} msg] | $msg | [imageNames] | 582} -cleanup { 583 imageCleanup 584} -result {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |} 585 586test image-13.3 {Tk_SizeOfImage procedure} -constraints testOldImageType -setup { 587 imageCleanup 588} -body { 589 image create oldtest foo -variable x 590 set result [list [image width foo] [image height foo]] 591 foo changed 0 0 0 0 85 60 592 lappend result [image width foo] [image height foo] 593} -cleanup { 594 imageCleanup 595} -result {30 15 85 60} 596 597test image-13.4 {DeleteImage procedure} -constraints testOldImageType -setup { 598 .c delete all 599 imageCleanup 600} -body { 601 image create oldtest foo -variable x 602 .c create image 50 50 -image foo -tags i1 603 .c create image 90 100 -image foo -tags i2 604 set x {} 605 image delete foo 606 lappend x | [imageNames] | [catch {image delete foo} msg] | $msg | [imageNames] | 607} -cleanup { 608 .c delete all 609 imageCleanup 610} -result {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |} 611 612test image-14.1 {image command vs hidden commands} -body { 613 catch {image delete hidden} 614 set l [imageNames] 615 set h [interp hidden] 616 image create photo hidden 617 interp hide {} hidden 618 image delete hidden 619 set res1 [list [imageNames] [interp hidden]] 620 set res2 [list $l $h] 621 expr {$res1 eq $res2} 622} -result 1 623 624test image-15.1 {deleting image does not make widgets forget about it} -setup { 625 .c delete all 626 imageCleanup 627} -body { 628 image create photo foo -width 10 -height 10 629 .c create image 10 10 -image foo -tags i1 -anchor nw 630 update 631 set x [.c bbox i1] 632 lappend x [imageNames] 633 image delete foo 634 lappend x [imageNames] 635 image create photo foo -width 20 -height 20 636 lappend x [.c bbox i1] [imageNames] 637} -cleanup { 638 .c delete all 639 imageCleanup 640} -result {10 10 20 20 foo {} {10 10 30 30} foo} 641 642destroy .c 643imageFinish 644 645# cleanup 646cleanupTests 647return 648 649# Local variables: 650# mode: tcl 651# End: 652