util/src/TclTk/tk8.6.12/tests/image.test

   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 package require tcltest 2.2
  11 namespace import ::tcltest::*
  12 eval tcltest::configure $argv
  13 tcltest::loadTestedCommands
  14
  15 imageInit
  16
  17 # Canvas used in some tests in the whole file
  18 canvas .c -highlightthickness 2
  19 pack .c
  20 update
  21
  22
  23 test image-1.1 {Tk_ImageCmd procedure, "create" option} -body {
  24     image
  25 } -returnCodes error -result {wrong # args: should be "image option ?args?"}
  26 test 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}
  29 test 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 ...?"}
  32 test 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}
  35 test 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}
  42 test 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
  55 test 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}}
  81 test 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}}
 102 test 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"}
 107 test image-1.10 {Tk_ImageCmd procedure, "create" option} -constraints {
 108     testImageType
 109 } -body {
 110     catch {image create test -badName foo}
 111     imageNames
 112 } -result {}
 113 test 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}}
 125 test 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}}
 137 test 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
 153 test image-2.1 {Tk_ImageCmd procedure, "delete" option} -body {
 154     image delete
 155 } -result {}
 156 test 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} {}}
 170 test 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}
 181 test 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
 195 test image-3.1 {Tk_ImageCmd procedure, "height" option} -body {
 196     image height
 197 } -returnCodes error -result {wrong # args: should be "image height name"}
 198 test 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"}
 201 test image-3.3 {Tk_ImageCmd procedure, "height" option} -body {
 202     image height foo
 203 } -returnCodes error -result {image "foo" doesn't exist}
 204 test 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
 218 test image-4.1 {Tk_ImageCmd procedure, "names" option} -body {
 219     image names x
 220 } -returnCodes error -result {wrong # args: should be "image names"}
 221 test 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}
 238 test 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
 253 test image-5.1 {Tk_ImageCmd procedure, "type" option} -body {
 254     image type
 255 } -returnCodes error -result {wrong # args: should be "image type name"}
 256 test 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"}
 259 test image-5.3 {Tk_ImageCmd procedure, "type" option} -body {
 260     image type foo
 261 } -returnCodes error -result {image "foo" doesn't exist}
 262
 263 test 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}
 273 test 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}
 285 test 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}
 295 test 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
 311 test image-6.1 {Tk_ImageCmd procedure, "types" option} -body {
 312     image types x
 313 } -returnCodes error -result {wrong # args: should be "image types"}
 314 test image-6.2 {Tk_ImageCmd procedure, "types" option} -body {
 315     lsort [image types]
 316 } -match glob -result {bitmap*photo test}
 317
 318
 319 test image-7.1 {Tk_ImageCmd procedure, "width" option} -body {
 320     image width
 321 } -returnCodes error -result {wrong # args: should be "image width name"}
 322 test image-7.2 {Tk_ImageCmd procedure, "width" option} -body {
 323     image width a b
 324 } -returnCodes error -result {wrong # args: should be "image width name"}
 325 test image-7.3 {Tk_ImageCmd procedure, "width" option} -body {
 326     image width foo
 327 } -returnCodes error -result {image "foo" doesn't exist}
 328 test image-7.4 {Tk_ImageCmd procedure, "width" option} -constraints {
 329     testImageType
 330 } -setup {
 331     imageCleanup
 332 } -body {
 333     image create test myimage
 334     set x [image w myimage]
 335     myimage changed 0 0 0 0 60 50
 336     list $x [image width myimage]
 337 } -cleanup {
 338     imageCleanup
 339 } -result {30 60}
 340
 341
 342 test image-8.1 {Tk_ImageCmd procedure, "inuse" option} -constraints {
 343     testImageType
 344 } -setup {
 345     imageCleanup
 346     set res {}
 347     destroy .b
 348 } -body {
 349     image create test myimage2
 350     lappend res [image inuse myimage2]
 351     button .b -image myimage2
 352     lappend res [image inuse myimage2]
 353 } -cleanup {
 354     imageCleanup
 355     catch {destroy .b}
 356 } -result [list 0 1]
 357
 358 test image-9.1 {Tk_ImageChanged procedure} -constraints testImageType -setup {
 359     .c delete all
 360     imageCleanup
 361     update
 362 } -body {
 363     image create test foo -variable x
 364     .c create image 50 50 -image foo
 365     update
 366     set x {}
 367     set timer [after 500 {lappend x "timed out"}]
 368     foo changed 5 6 7 8 30 15
 369     update idletasks
 370     update
 371     # On MacOS we need to wait for the test image display procedure to run.
 372     while {"timed out" ni $x && [lindex $x end 1] ne "display"} {
 373         vwait x
 374     }
 375     after cancel $timer
 376     return $x
 377 } -cleanup {
 378     .c delete all
 379     imageCleanup
 380 } -result {{foo display 5 6 7 8}}
 381
 382 test image-9.2 {Tk_ImageChanged procedure} -constraints testImageType -setup {
 383     .c delete all
 384     imageCleanup
 385     update
 386 } -body {
 387     image create test foo -variable x
 388     .c create image 50 50 -image foo
 389     .c create image 90 100 -image foo
 390     update
 391     set x {}
 392     foo changed 5 6 7 8 30 15
 393     set timer [after 500 {lappend x "timed out"}]
 394     image create test myimage -variable x
 395     vwait x
 396     after cancel $timer
 397     return $x
 398 } -cleanup {
 399     .c delete all
 400     imageCleanup
 401 } -result {{foo display 5 6 25 9} {foo display 0 0 12 14}}
 402
 403 test image-10.1 {Tk_GetImage procedure} -setup {
 404     imageCleanup
 405 } -body {
 406     .c create image 100 10 -image bad_name
 407 } -cleanup {
 408     imageCleanup
 409 } -returnCodes error -result {image "bad_name" doesn't exist}
 410 test image-10.2 {Tk_GetImage procedure} -constraints testImageType -setup {
 411     destroy .l
 412     imageCleanup
 413 } -body {
 414     image create test mytest
 415     label .l -image mytest
 416     image delete  mytest
 417     label .l2 -image mytest
 418 } -cleanup {
 419     destroy .l
 420     imageCleanup
 421 } -returnCodes error -result {image "mytest" doesn't exist}
 422
 423
 424 test image-11.1 {Tk_FreeImage procedure} -constraints testImageType -setup {
 425     .c delete all
 426     imageCleanup
 427 } -body {
 428     image create test foo -variable x
 429     .c create image 50 50 -image foo -tags i1
 430     .c create image 90 100 -image foo -tags i2
 431     pack forget .c
 432     update
 433     set x {}
 434     .c delete i1
 435     set timer [after 500 {lappend x "timed out"}]
 436     pack .c
 437     vwait x
 438     after cancel $timer
 439     list [imageNames] $x
 440 } -cleanup {
 441     .c delete all
 442     imageCleanup
 443 } -result {foo {{foo free} {foo display 0 0 30 15}}}
 444 test image-11.2 {Tk_FreeImage procedure} -constraints testImageType -setup {
 445     .c delete all
 446     imageCleanup
 447 } -body {
 448     image create test foo -variable x
 449     .c create image 50 50 -image foo -tags i1
 450     set names [imageNames]
 451     image delete foo
 452     update
 453     set names2 [imageNames]
 454     set x {}
 455     .c delete i1
 456     pack forget .c
 457     pack .c
 458     update
 459     list $names $names2 [imageNames] $x
 460 } -cleanup {
 461     .c delete all
 462     imageCleanup
 463 } -result {foo {} {} {}}
 464
 465
 466 # Non-portable, apparently due to differences in rounding:
 467 test image-12.1 {Tk_RedrawImage procedure, redisplay area clipping} -constraints {
 468     testImageType nonPortable
 469 } -setup {
 470     imageCleanup
 471 } -body {
 472     image create test foo -variable x
 473     .c create image 50 60 -image foo -tags i1 -anchor nw
 474     update
 475     .c create rectangle 30 40 55 65 -width 0 -fill black -outline {}
 476     set x {}
 477     update
 478     return $x
 479 } -cleanup {
 480     imageCleanup
 481 } -result {{foo display 0 0 5 5 50 50}}
 482 test image-12.2 {Tk_RedrawImage procedure, redisplay area clipping} -constraints {
 483     testImageType nonPortable
 484 } -setup {
 485     imageCleanup
 486 } -body {
 487     image create test foo -variable x
 488     .c create image 50 60 -image foo -tags i1 -anchor nw
 489     update
 490     .c create rectangle 60 40 100 65 -width 0 -fill black -outline {}
 491     set x {}
 492     update
 493     return $x
 494 } -cleanup {
 495     imageCleanup
 496 } -result {{foo display 10 0 20 5 30 50}}
 497 test image-12.3 {Tk_RedrawImage procedure, redisplay area clipping} -constraints {
 498     testImageType nonPortable
 499 } -setup {
 500     imageCleanup
 501 } -body {
 502     image create test foo -variable x
 503     .c create image 50 60 -image foo -tags i1 -anchor nw
 504     update
 505     .c create rectangle 60 70 100 200 -width 0 -fill black -outline {}
 506     set x {}
 507     update
 508     return $x
 509 } -cleanup {
 510     imageCleanup
 511 } -result {{foo display 10 10 20 5 30 30}}
 512 test image-12.4 {Tk_RedrawImage procedure, redisplay area clipping} -constraints {
 513     testImageType nonPortable
 514 } -setup {
 515     imageCleanup
 516 } -body {
 517     image create test foo -variable x
 518     .c create image 50 60 -image foo -tags i1 -anchor nw
 519     update
 520     .c create rectangle 30 70 55 200 -width 0 -fill black -outline {}
 521     set x {}
 522     update
 523     return $x
 524 } -cleanup {
 525     imageCleanup
 526 } -result {{foo display 0 10 5 5 50 30}}
 527 test image-12.5 {Tk_RedrawImage procedure, redisplay area clipping} -constraints {
 528     testImageType nonPortable
 529 } -setup {
 530     imageCleanup
 531 } -body {
 532     image create test foo -variable x
 533     .c create image 50 60 -image foo -tags i1 -anchor nw
 534     update
 535     .c create rectangle 10 20 120 130 -width 0 -fill black -outline {}
 536     set x {}
 537     update
 538     return $x
 539 } -cleanup {
 540     imageCleanup
 541 } -result {{foo display 0 0 30 15 70 70}}
 542 test image-12.6 {Tk_RedrawImage procedure, redisplay area clipping} -constraints {
 543     testImageType nonPortable
 544 } -setup {
 545     imageCleanup
 546 } -body {
 547     image create test foo -variable x
 548     .c create image 50 60 -image foo -tags i1 -anchor nw
 549     update
 550     .c create rectangle 55 65 75 70 -width 0 -fill black -outline {}
 551     set x {}
 552     update
 553     return $x
 554 } -cleanup {
 555     imageCleanup
 556 } -result {{foo display 5 5 20 5 30 30}}
 557
 558
 559 test image-13.1 {Tk_SizeOfImage procedure} -constraints testImageType -setup {
 560     imageCleanup
 561 } -body {
 562     image create test foo -variable x
 563     set result [list [image width foo] [image height foo]]
 564     foo changed 0 0 0 0 85 60
 565     lappend result [image width foo] [image height foo]
 566 } -cleanup {
 567     imageCleanup
 568 } -result {30 15 85 60}
 569
 570 test image-13.2 {DeleteImage procedure} -constraints testImageType -setup {
 571     .c delete all
 572     imageCleanup
 573 } -body {
 574     image create test foo -variable x
 575     .c create image 50 50 -image foo -tags i1
 576     .c create image 90 100 -image foo -tags i2
 577     set x {}
 578     image delete foo
 579     lappend x | [imageNames] | [catch {image delete foo} msg] | $msg | [imageNames] |
 580 } -cleanup {
 581     imageCleanup
 582 } -result {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |}
 583
 584 test image-13.3 {Tk_SizeOfImage procedure} -constraints testOldImageType -setup {
 585     imageCleanup
 586 } -body {
 587     image create oldtest foo -variable x
 588     set result [list [image width foo] [image height foo]]
 589     foo changed 0 0 0 0 85 60
 590     lappend result [image width foo] [image height foo]
 591 } -cleanup {
 592     imageCleanup
 593 } -result {30 15 85 60}
 594
 595 test image-13.4 {DeleteImage procedure} -constraints testOldImageType -setup {
 596     .c delete all
 597     imageCleanup
 598 } -body {
 599     image create oldtest foo -variable x
 600     .c create image 50 50 -image foo -tags i1
 601     .c create image 90 100 -image foo -tags i2
 602     set x {}
 603     image delete foo
 604     lappend x | [imageNames] | [catch {image delete foo} msg] | $msg | [imageNames] |
 605 } -cleanup {
 606     .c delete all
 607     imageCleanup
 608 } -result {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |}
 609
 610 test image-14.1 {image command vs hidden commands} -body {
 611     catch {image delete hidden}
 612     set l [imageNames]
 613     set h [interp hidden]
 614     image create photo hidden
 615     interp hide {} hidden
 616     image delete hidden
 617     set res1 [list [imageNames] [interp hidden]]
 618     set res2 [list $l $h]
 619     expr {$res1 eq $res2}
 620 } -result 1
 621
 622 test image-15.1 {deleting image does not make widgets forget about it} -setup {
 623     .c delete all
 624     imageCleanup
 625 } -body {
 626     image create photo foo -width 10 -height 10
 627     .c create image 10 10 -image foo -tags i1 -anchor nw
 628     update
 629     set x [.c bbox i1]
 630     lappend x [imageNames]
 631     image delete foo
 632     lappend x [imageNames]
 633     image create photo foo -width 20 -height 20
 634     lappend x [.c bbox i1] [imageNames]
 635 } -cleanup {
 636     .c delete all
 637     imageCleanup
 638 } -result {10 10 20 20 foo {} {10 10 30 30} foo}
 639
 640 destroy .c
 641 imageFinish
 642
 643 # cleanup
 644 cleanupTests
 645 return
 646
 647 # Local variables:
 648 # mode: tcl
 649 # End: