1# This file is a Tcl script to test out the "photo" image type and the 2# other procedures in the file tkImgPhoto.c. It is organized in the 3# standard fashion for Tcl tests. 4# 5# Copyright (c) 1994 The Australian National University 6# Copyright (c) 1994-1997 Sun Microsystems, Inc. 7# Copyright (c) 1998-1999 by Scriptics Corporation. 8# All rights reserved. 9# 10# Author: Paul Mackerras (paulus@cs.anu.edu.au) 11# 12# RCS: @(#) $Id: imgPhoto.test,v 1.15.2.6 2008/02/01 16:59:58 rmax Exp $ 13 14package require tcltest 2.1 15namespace import -force tcltest::configure 16namespace import -force tcltest::testsDirectory 17configure -testdir [file join [pwd] [file dirname [info script]]] 18configure -loadfile [file join [testsDirectory] constraints.tcl] 19tcltest::loadTestedCommands 20 21namespace import -force tcltest::makeFile 22namespace import -force tcltest::removeFile 23 24eval image delete [image names] 25 26canvas .c 27pack .c 28update 29 30set README [makeFile { 31README -- Tk test suite design document. 32} README-imgPhotot] 33 34# find the teapot.ppm file for use in these tests 35# first look in $tk_library/demos/images/teapot.ppm 36# then look in <this file>/../../library/demos/images/teapot.ppm 37testConstraint hasTeapotPhoto 1 38set teapotPhotoFile [file join $tk_library demos images teapot.ppm] 39if {![file exists $teapotPhotoFile]} { 40 set newLib [file dirname [testsDirectory]] 41 set teapotPhotoFile [file join $newLib library demos images teapot.ppm] 42 if {![file exists $teapotPhotoFile]} { 43 testConstraint hasTeapotPhoto 44 } 45} 46 47test imgPhoto-1.1 {options for photo images} { 48 image create photo p1 -width 79 -height 83 49 list [lindex [p1 configure -width] 4] [lindex [p1 configure -height] 4] \ 50 [image width p1] [image height p1] 51} {79 83 79 83} 52test imgPhoto-1.2 {options for photo images} { 53 list [catch {image create photo p1 -file no.such.file} err] \ 54 [string tolower $err] 55} {1 {couldn't open "no.such.file": no such file or directory}} 56test imgPhoto-1.3 {options for photo images} hasTeapotPhoto { 57 list [catch {image create photo p1 -file $teapotPhotoFile \ 58 -format no.such.format} err] $err 59} {1 {image file format "no.such.format" is not supported}} 60test imgPhoto-1.4 {options for photo images} hasTeapotPhoto { 61 image create photo p1 -file $teapotPhotoFile 62 list [image width p1] [image height p1] 63} {256 256} 64test imgPhoto-1.5 {options for photo images} hasTeapotPhoto { 65 image create photo p1 -file $teapotPhotoFile \ 66 -format ppm -width 79 -height 83 67 list [image width p1] [image height p1] \ 68 [lindex [p1 configure -file] 4] [lindex [p1 configure -format] 4] 69} [list 79 83 $teapotPhotoFile ppm] 70test imgPhoto-1.6 {options for photo images} { 71 image create photo p1 -palette 2/2/2 -gamma 2.2 72 list [format %.1f [lindex [p1 configure -gamma] 4]] \ 73 [lindex [p1 configure -palette] 4] 74} {2.2 2/2/2} 75test imgPhoto-1.7 {options for photo images} { 76 list [catch {image create photo p1 -file $README} err] $err 77} [subst {1 {couldn't recognize data in image file "$README"}}] 78test imgPhoto-1.8 {options for photo images} { 79 list [catch {image create photo -blah blah} err] $err 80} {1 {unknown option "-blah"}} 81test imgPhoto-1.9 {options for photo images - error case} { 82 list [catch {image create photo -format} err] $err 83} {1 {value for "-format" missing}} 84test imgPhoto-1.10 {options for photo images - error case} { 85 list [catch {image create photo -data} err] $err 86} {1 {value for "-data" missing}} 87test imgPhoto-1.11 {options for photo images - error case} { 88 list [catch {image create photo p1 -format} err] $err 89} {1 {value for "-format" missing}} 90 91test imgPhoto-2.1 {ImgPhotoCreate procedure} { 92 eval image delete [image names] 93 catch {image create photo -blah blah} 94 image names 95} {} 96test imgPhoto-2.2 {ImgPhotoCreate procedure} { 97 eval image delete [image names] 98 image create photo image1 99 list [info commands image1] [image names] \ 100 [image width image1] [image height image1] 101} {image1 image1 0 0} 102# test imgPhoto-2.3 {ImgPhotoCreate procedure: creation failure} { 103# image create photo p1 104# image create photo p2 -width 10 -height 10 105# catch {image create photo p2 -file bogus.img} msg 106# p1 copy p2 107# set msg 108# } {couldn't open "bogus.img": no such file or directory} 109 110test imgPhoto-3.1 {ImgPhotoConfigureMaster procedure} hasTeapotPhoto { 111 image create photo p1 -file $teapotPhotoFile 112 p1 configure -file $teapotPhotoFile 113} {} 114test imgPhoto-3.2 {ImgPhotoConfigureMaster procedure} hasTeapotPhoto { 115 image create photo p1 -file $teapotPhotoFile 116 list [catch {p1 configure -file bogus} err] [string tolower $err] \ 117 [image width p1] [image height p1] 118} {1 {couldn't open "bogus": no such file or directory} 256 256} 119test imgPhoto-3.3 {ImgPhotoConfigureMaster procedure} hasTeapotPhoto { 120 image create photo p1 121 .c create image 10 10 -image p1 -tags p1.1 -anchor nw 122 .c create image 300 10 -image p1 -tags p1.2 -anchor nw 123 update 124 p1 configure -file $teapotPhotoFile 125 update 126 list [image width p1] [image height p1] [.c bbox p1.1] [.c bbox p1.2] 127} {256 256 {10 10 266 266} {300 10 556 266}} 128 129eval image delete [image names] 130image create photo p1 131.c create image 10 10 -image p1 132update 133 134test imgPhoto-4.1 {ImgPhotoCmd procedure} { 135 list [catch {p1} err] $err 136} {1 {wrong # args: should be "p1 option ?arg arg ...?"}} 137test imgPhoto-4.2 {ImgPhotoCmd procedure} { 138 list [catch {p1 blah} err] $err 139} {1 {bad option "blah": must be blank, cget, configure, copy, data, get, put, read, redither, transparency, or write}} 140test imgPhoto-4.3 {ImgPhotoCmd procedure: blank option} { 141 p1 blank 142 list [catch {p1 blank x} err] $err 143} {1 {wrong # args: should be "p1 blank"}} 144test imgPhoto-4.4 {ImgPhotoCmd procedure: cget option} { 145 list [catch {p1 cget} msg] $msg 146} {1 {wrong # args: should be "p1 cget option"}} 147test imgPhoto-4.5 {ImgPhotoCmd procedure: cget option} { 148 image create photo p2 -width 25 -height 30 149 list [p2 cget -width] [p2 cget -height] 150} {25 30} 151test imgPhoto-4.6 {ImgPhotoCmd procedure: configure option} { 152 llength [p1 configure] 153} {7} 154test imgPhoto-4.7 {ImgPhotoCmd procedure: configure option} { 155 p1 conf -palette 3/4/2 156 p1 configure -palette 157} {-palette {} {} {} 3/4/2} 158test imgPhoto-4.8 {ImgPhotoCmd procedure: configure option} { 159 list [catch {p1 configure -blah} msg] $msg 160} {1 {unknown option "-blah"}} 161test imgPhoto-4.9 {ImgPhotoCmd procedure: configure option} { 162 list [catch {p1 configure -palette {} -gamma} msg] $msg 163} {1 {value for "-gamma" missing}} 164test imgPhoto-4.10 {ImgPhotoCmd procedure: copy option} hasTeapotPhoto { 165 image create photo p2 -file $teapotPhotoFile 166 p1 configure -width 0 -height 0 -palette {} -gamma 1 167 p1 copy p2 168 list [image width p1] [image height p1] [p1 get 100 100] 169} {256 256 {169 117 90}} 170test imgPhoto-4.11 {ImgPhotoCmd procedure: copy option} { 171 list [catch {p1 copy} msg] $msg 172} {1 {wrong # args: should be "p1 copy source-image ?-compositingrule rule? ?-from x1 y1 x2 y2? ?-to x1 y1 x2 y2? ?-zoom x y? ?-subsample x y?"}} 173test imgPhoto-4.12 {ImgPhotoCmd procedure: copy option} { 174 list [catch {p1 copy blah} msg] $msg 175} {1 {image "blah" doesn't exist or is not a photo image}} 176test imgPhoto-4.13 {ImgPhotoCmd procedure: copy option} { 177 list [catch {p1 copy p2 -blah} msg] $msg 178} {1 {unrecognized option "-blah": must be -compositingrule, -from, -shrink, -subsample, -to, or -zoom}} 179test imgPhoto-4.14 {ImgPhotoCmd procedure: copy option} { 180 list [catch {p1 copy p2 -from -to} msg] $msg 181} {1 {the "-from" option requires one to four integer values}} 182test imgPhoto-4.15 {ImgPhotoCmd procedure: copy option} { 183 p1 copy p2 184 p1 copy p2 -from 0 70 60 120 -shrink 185 list [image width p1] [image height p1] [p1 get 20 10] 186} {60 50 {215 154 120}} 187test imgPhoto-4.16 {ImgPhotoCmd procedure: copy option} { 188 p1 copy p2 -from 60 120 0 70 -to 20 50 189 list [image width p1] [image height p1] [p1 get 40 80] 190} {80 100 {19 92 192}} 191test imgPhoto-4.17 {ImgPhotoCmd procedure: copy option} { 192 p1 copy p2 -from 0 120 60 70 -to 0 0 100 100 193 list [image width p1] [image height p1] [p1 get 80 60] 194} {100 100 {215 154 120}} 195test imgPhoto-4.18 {ImgPhotoCmd procedure: copy option} { 196 p1 copy p2 -from 60 70 0 120 -zoom 2 197 list [image width p1] [image height p1] [p1 get 100 50] 198} {120 100 {169 99 47}} 199test imgPhoto-4.19 {ImgPhotoCmd procedure: copy option} { 200 p1 copy p2 -from 0 70 60 120 201 list [image width p1] [image height p1] [p1 get 100 50] 202} {120 100 {169 99 47}} 203test imgPhoto-4.20 {ImgPhotoCmd procedure: copy option} { 204 p1 copy p2 -from 20 20 200 180 -subsample 2 -shrink 205 list [image width p1] [image height p1] [p1 get 50 30] 206} {90 80 {207 146 112}} 207test imgPhoto-4.21 {ImgPhotoCmd procedure: copy option} { 208 p1 copy p2 209 set result [list [image width p1] [image height p1]] 210 p1 conf -width 49 -height 51 211 lappend result [image width p1] [image height p1] 212 p1 copy p2 213 lappend result [image width p1] [image height p1] 214 p1 copy p2 -from 0 0 10 10 -shrink 215 lappend result [image width p1] [image height p1] 216 p1 conf -width 0 217 p1 copy p2 -from 0 0 10 10 -shrink 218 lappend result [image width p1] [image height p1] 219 p1 conf -height 0 220 p1 copy p2 -from 0 0 10 10 -shrink 221 lappend result [image width p1] [image height p1] 222} {256 256 49 51 49 51 49 51 10 51 10 10} 223test imgPhoto-4.22 {ImgPhotoCmd procedure: get option} hasTeapotPhoto { 224 p1 read $teapotPhotoFile 225 list [p1 get 100 100] [p1 get 150 100] [p1 get 100 150] 226} {{169 117 90} {172 115 84} {35 35 35}} 227test imgPhoto-4.23 {ImgPhotoCmd procedure: get option} { 228 list [catch {p1 get 256 0} err] $err 229} {1 {p1 get: coordinates out of range}} 230test imgPhoto-4.24 {ImgPhotoCmd procedure: get option} { 231 list [catch {p1 get 0 -1} err] $err 232} {1 {p1 get: coordinates out of range}} 233test imgPhoto-4.25 {ImgPhotoCmd procedure: get option} { 234 list [catch {p1 get} err] $err 235} {1 {wrong # args: should be "p1 get x y"}} 236test imgPhoto-4.26 {ImgPhotoCmd procedure: put option} { 237 list [catch {p1 put} err] $err 238} {1 {wrong # args: should be "p1 put data ?options?"}} 239test imgPhoto-4.27 {ImgPhotoCmd procedure: put option} { 240 list [catch {p1 put {{white} {white white}}} err] $err 241} {1 {all elements of color list must have the same number of elements}} 242test imgPhoto-4.28 {ImgPhotoCmd procedure: put option} { 243 list [catch {p1 put {{blahgle}}} err] $err 244} {1 {can't parse color "blahgle"}} 245test imgPhoto-4.29 {ImgPhotoCmd procedure: put option} { 246 p1 put -to 10 10 20 20 {{white}} 247 p1 get 19 19 248} {255 255 255} 249test imgPhoto-4.30 {ImgPhotoCmd procedure: read option} { 250 list [catch {p1 read} err] $err 251} {1 {wrong # args: should be "p1 read fileName ?options?"}} 252test imgPhoto-4.31 {ImgPhotoCmd procedure: read option} hasTeapotPhoto { 253 list [catch {p1 read $teapotPhotoFile -zoom 2} err] $err 254} {1 {unrecognized option "-zoom": must be -format, -from, -shrink, or -to}} 255test imgPhoto-4.32 {ImgPhotoCmd procedure: read option} { 256 list [catch {p1 read bogus} err] [string tolower $err] 257} {1 {couldn't open "bogus": no such file or directory}} 258test imgPhoto-4.33 {ImgPhotoCmd procedure: read option} hasTeapotPhoto { 259 list [catch {p1 read $teapotPhotoFile -format bogus} err] $err 260} {1 {image file format "bogus" is not supported}} 261test imgPhoto-4.34 {ImgPhotoCmd procedure: read option} { 262 list [catch {p1 read $README} err] $err 263} [subst {1 {couldn't recognize data in image file "$README"}}] 264test imgPhoto-4.35 {ImgPhotoCmd procedure: read option} hasTeapotPhoto { 265 p1 read $teapotPhotoFile 266 list [image width p1] [image height p1] [p1 get 120 120] 267} {256 256 {161 109 82}} 268test imgPhoto-4.36 {ImgPhotoCmd procedure: read option} hasTeapotPhoto { 269 p1 read $teapotPhotoFile -from 0 70 60 120 -to 10 10 -shrink 270 list [image width p1] [image height p1] [p1 get 29 19] 271} {70 60 {244 180 144}} 272test imgPhoto-4.37 {ImgPhotoCmd procedure: redither option} { 273 p1 redither 274 list [catch {p1 redither x} err] $err 275} {1 {wrong # args: should be "p1 redither"}} 276test imgPhoto-4.38 {ImgPhotoCmd procedure: write option} { 277 list [catch {p1 write} err] $err 278} {1 {wrong # args: should be "p1 write fileName ?options?"}} 279test imgPhoto-4.39 {ImgPhotoCmd procedure: write option} { 280 list [catch {p1 write teapot.tmp -format bogus} err] $err 281} {1 {image file format "bogus" is unknown}} 282eval image delete [image names] 283image create photo p1 284test imgPhoto-4.40 {ImgPhotoCmd procedure: transparency option} { 285 list [catch {p1 transparency} err] $err 286} {1 {wrong # args: should be "p1 transparency option ?arg arg ...?"}} 287test imgPhoto-4.41 {ImgPhotoCmd procedure: transparency get option} { 288 list [catch {p1 transparency get} err] $err 289} {1 {wrong # args: should be "p1 transparency get x y"}} 290test imgPhoto-4.42 {ImgPhotoCmd procedure: transparency get option} { 291 list [catch {p1 transparency get 0} err] $err 292} {1 {wrong # args: should be "p1 transparency get x y"}} 293test imgPhoto-4.43 {ImgPhotoCmd procedure: transparency get option} { 294 list [catch {p1 transparency get 0 0 0} err] $err 295} {1 {wrong # args: should be "p1 transparency get x y"}} 296test imgPhoto-4.44 {ImgPhotoCmd procedure: transparency get option} { 297 list [catch {p1 transparency get bogus 0} err] $err 298} {1 {expected integer but got "bogus"}} 299test imgPhoto-4.45 {ImgPhotoCmd procedure: transparency get option} { 300 list [catch {p1 transparency get 0 bogus} err] $err 301} {1 {expected integer but got "bogus"}} 302test imgPhoto-4.46 {ImgPhotoCmd procedure: transparency get option} { 303 p1 put white 304 p1 transparency get 0 0 305} 0 306test imgPhoto-4.47 {ImgPhotoCmd procedure: transparency get option} { 307 list [catch {p1 transparency get 1 0} err] $err 308} {1 {p1 transparency get: coordinates out of range}} 309test imgPhoto-4.48 {ImgPhotoCmd procedure: transparency get option} { 310 list [catch {p1 transparency get -1 0} err] $err 311} {1 {p1 transparency get: coordinates out of range}} 312test imgPhoto-4.49 {ImgPhotoCmd procedure: transparency get option} { 313 list [catch {p1 transparency get 0 1} err] $err 314} {1 {p1 transparency get: coordinates out of range}} 315test imgPhoto-4.50 {ImgPhotoCmd procedure: transparency get option} { 316 list [catch {p1 transparency get 0 -1} err] $err 317} {1 {p1 transparency get: coordinates out of range}} 318test imgPhoto-4.51 {ImgPhotoCmd procedure: transparency get option} { 319 p1 blank 320 p1 transparency get 0 0 321} 1 322test imgPhoto-4.52 {ImgPhotoCmd procedure: transparency set option} { 323 list [catch {p1 transparency set} err] $err 324} {1 {wrong # args: should be "p1 transparency set x y boolean"}} 325test imgPhoto-4.53 {ImgPhotoCmd procedure: transparency set option} { 326 list [catch {p1 transparency set 0} err] $err 327} {1 {wrong # args: should be "p1 transparency set x y boolean"}} 328test imgPhoto-4.54 {ImgPhotoCmd procedure: transparency set option} { 329 list [catch {p1 transparency set 0 0} err] $err 330} {1 {wrong # args: should be "p1 transparency set x y boolean"}} 331test imgPhoto-4.55 {ImgPhotoCmd procedure: transparency set option} { 332 list [catch {p1 transparency set 0 0 0 0} err] $err 333} {1 {wrong # args: should be "p1 transparency set x y boolean"}} 334test imgPhoto-4.56 {ImgPhotoCmd procedure: transparency set option} { 335 list [catch {p1 transparency set bogus 0 0} err] $err 336} {1 {expected integer but got "bogus"}} 337test imgPhoto-4.57 {ImgPhotoCmd procedure: transparency set option} { 338 list [catch {p1 transparency set 0 bogus 0} err] $err 339} {1 {expected integer but got "bogus"}} 340test imgPhoto-4.58 {ImgPhotoCmd procedure: transparency set option} { 341 list [catch {p1 transparency set 0 0 bogus} err] $err 342} {1 {expected boolean value but got "bogus"}} 343test imgPhoto-4.59 {ImgPhotoCmd procedure: transparency set option} { 344 list [catch {p1 transparency set 1 0 0} err] $err 345} {1 {p1 transparency set: coordinates out of range}} 346test imgPhoto-4.60 {ImgPhotoCmd procedure: transparency set option} { 347 list [catch {p1 transparency set -1 0 0} err] $err 348} {1 {p1 transparency set: coordinates out of range}} 349test imgPhoto-4.61 {ImgPhotoCmd procedure: transparency set option} { 350 list [catch {p1 transparency set 0 1 0} err] $err 351} {1 {p1 transparency set: coordinates out of range}} 352test imgPhoto-4.62 {ImgPhotoCmd procedure: transparency set option} { 353 list [catch {p1 transparency set 0 -1 0} err] $err 354} {1 {p1 transparency set: coordinates out of range}} 355test imgPhoto-4.63 {ImgPhotoCmd procedure: transparency set option} { 356 p1 transparency set 0 0 false 357 p1 transparency get 0 0 358} 0 359test imgPhoto-4.64 {ImgPhotoCmd procedure: transparency set option} { 360 p1 transparency set 0 0 true 361 p1 transparency get 0 0 362} 1 363# Now for some heftier testing, checking that setting and resetting of 364# pixels' transparency status doesn't "leak" with any one-off errors. 365proc checkImgTrans {img width height} { 366 set result {} 367 for {set x 0} {$x<$width} {incr x} { 368 for {set y 0} {$y<$height} {incr y} { 369 if {[$img transparency get $x $y]} { 370 lappend result $x $y 371 } 372 } 373 } 374 return $result 375} 376test imgPhoto-4.65 {ImgPhotoCmd procedure: transparency get option} { 377 p1 put white -to 0 0 3 3 378 checkImgTrans p1 3 3 379} {} 380test imgPhoto-4.66 {ImgPhotoCmd procedure: transparency get option} { 381 p1 blank 382 checkImgTrans p1 3 3 383} {0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2} 384proc checkImgTransLoopSetReset {img width height} { 385 set result {} 386 for {set x 0} {$x<$width} {incr x} { 387 for {set y 0} {$y<$height} {incr y} { 388 $img put white -to 0 0 3 3 389 $img transparency set $x $y 1 390 set result [concat $result [checkImgTrans $img $width $height]] 391 lappend result , 392 $img transparency set $x $y 0 393 set result [concat $result [checkImgTrans $img $width $height]] 394 lappend result . 395 } 396 } 397 return $result 398} 399test imgPhoto-4.67 {ImgPhotoCmd procedure: transparency set option} { 400 checkImgTransLoopSetReset p1 3 3 401} {0 0 , . 0 1 , . 0 2 , . 1 0 , . 1 1 , . 1 2 , . 2 0 , . 2 1 , . 2 2 , .} 402proc checkImgTransLoopResetSet {img width height} { 403 set result {} 404 for {set x 0} {$x<$width} {incr x} { 405 for {set y 0} {$y<$height} {incr y} { 406 $img blank 407 $img transparency set $x $y 0 408 set result [concat $result [checkImgTrans $img $width $height]] 409 lappend result , 410 $img transparency set $x $y 1 411 set result [concat $result [checkImgTrans $img $width $height]] 412 lappend result . 413 } 414 } 415 return $result 416} 417test imgPhoto-4.68 {ImgPhotoCmd procedure: transparency set option} { 418 checkImgTransLoopResetSet p1 3 3 419} {0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 2 1 0 1 1 1 2 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 1 0 1 1 1 2 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 1 1 2 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 0 1 2 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 0 1 1 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 0 1 1 1 2 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 .} 420catch {rename checkImgTransLoopSetReset {}} 421catch {rename checkImgTransLoopResetSet {}} 422# Test the compositing rules for copying images 423image create photo p1 -width 3 -height 3 424image create photo p2 -width 2 -height 2 425test imgPhoto-4.68 {ImgPhotoCmd procedure: copy with -compositingrule} { 426 list [catch {p1 copy p2 -to 1 1 -compositingrule} msg] $msg 427} {1 {the "-compositingrule" option requires a value}} 428test imgPhoto-4.69 {ImgPhotoCmd procedure: copy with -compositingrule} { 429 list [catch {p1 copy p2 -to 1 1 -compositingrule BAD} msg] $msg 430} {1 {bad compositing rule "BAD": must be overlay or set}} 431test imgPhoto-4.70 {ImgPhotoCmd procedure: copy with -compositingrule} { 432 # Tests default compositing rule 433 p1 blank 434 p2 blank 435 p1 put white -to 0 0 2 2 436 p2 put white -to 0 0 2 2 437 p2 transparency set 0 0 true 438 p1 copy p2 -to 1 1 439 checkImgTrans p1 3 3 440} {0 2 2 0} 441test imgPhoto-4.71 {ImgPhotoCmd procedure: copy with -compositingrule} { 442 p1 blank 443 p2 blank 444 p1 put white -to 0 0 2 2 445 p2 put white -to 0 0 2 2 446 p2 transparency set 0 0 true 447 p1 copy p2 -to 1 1 -compositingrule overlay 448 checkImgTrans p1 3 3 449} {0 2 2 0} 450test imgPhoto-4.72 {ImgPhotoCmd procedure: copy with -compositingrule} { 451 p1 blank 452 p2 blank 453 p1 put white -to 0 0 2 2 454 p2 put white -to 0 0 2 2 455 p2 transparency set 0 0 true 456 p1 copy p2 -to 1 1 -compositingrule set 457 checkImgTrans p1 3 3 458} {0 2 1 1 2 0} 459catch {rename checkImgTrans {}} 460 461test imgPhoto-5.1 {ImgPhotoGet/Free procedures, shared instances} hasTeapotPhoto { 462 eval image delete [image names] 463 .c delete all 464 image create photo p1 -file $teapotPhotoFile 465 .c create image 0 0 -image p1 -tags p1.1 466 .c create image 256 0 -image p1 -tags p1.2 467 .c create image 0 256 -image p1 -tags p1.3 468 update 469 .c delete i1.1 470 p1 configure -width 1 471 update 472 .c delete i1.2 473 p1 configure -height 1 474 update 475 image delete p1 476} {} 477 478test imgPhoto-6.1 {ImgPhotoDisplay procedure, blank display} { 479 .c delete all 480 image create photo p1 -width 10 -height 10 481 p1 blank 482 .c create image 10 10 -image p1 483 update 484} {} 485 486test imgPhoto-7.1 {ImgPhotoFree procedure, resource freeing} hasTeapotPhoto { 487 eval image delete [image names] 488 .c delete all 489 image create photo p1 -file $teapotPhotoFile 490 .c create image 0 0 -image p1 -anchor nw 491 update 492 .c delete all 493 image delete p1 494} {} 495test imgPhoto-7.2 {ImgPhotoFree procedures, unlinking} hasTeapotPhoto { 496 image create photo p1 -file $teapotPhotoFile 497 .c create image 10 10 -image p1 -anchor nw 498 button .b1 -image p1 499 button .b2 -image p1 500 button .b3 -image p1 501 pack .b1 .b2 .b3 502 update 503 destroy .b2 504 update 505 destroy .b3 506 update 507 destroy .b1 508 update 509 .c delete all 510} {} 511test imgPhoto-7.3 {ImgPhotoFree procedures, multiple visuals} hasTeapotPhoto { 512 image create photo p1 -file $teapotPhotoFile 513 button .b1 -image p1 514 frame .f -visual best 515 button .f.b2 -image p1 516 pack .f.b2 517 pack .b1 .f 518 update 519 destroy .b1 520 update 521 .f.b2 configure -image {} 522 update 523 destroy .f 524 image delete p1 525} {} 526 527test imgPhoto-8.1 {ImgPhotoDelete procedure} hasTeapotPhoto { 528 image create photo p2 -file $teapotPhotoFile 529 image delete p2 530} {} 531test imagePhoto-8.2 {ImgPhotoDelete procedure} hasTeapotPhoto { 532 image create photo p2 -file $teapotPhotoFile 533 rename p2 newp2 534 set x [list [info command p2] [info command new*] [newp2 cget -file]] 535 image delete p2 536 append x [info command new*] 537} [list {} newp2 $teapotPhotoFile] 538test imagePhoto-8.3 {ImgPhotoDelete procedure, name cleanup} { 539 image create photo p1 540 image create photo p2 -width 10 -height 10 541 image delete p2 542 list [catch {p1 copy p2} msg] $msg 543} {1 {image "p2" doesn't exist or is not a photo image}} 544 545test imagePhoto-9.1 {ImgPhotoCmdDeletedProc procedure} hasTeapotPhoto { 546 image create photo p2 -file $teapotPhotoFile 547 rename p2 {} 548 list [lsearch -exact [image names] p2] [catch {p2 foo} msg] $msg 549} {-1 1 {invalid command name "p2"}} 550 551test imgPhoto-10.1 {Tk_ImgPhotoPutBlock procedure} { 552 eval image delete [image names] 553 image create photo p1 554 p1 put {{#ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000}} -to 0 0 555 p1 put {{#00ff00 #00ff00}} -to 2 0 556 list [p1 get 2 0] [p1 get 3 0] [p1 get 4 0] 557} {{0 255 0} {0 255 0} {255 0 0}} 558 559test imgPhoto-11.1 {Tk_FindPhoto} { 560 eval image delete [image names] 561 image create bitmap i1 562 image create photo p1 563 list [catch {p1 copy i1} msg] $msg 564} {1 {image "i1" doesn't exist or is not a photo image}} 565 566test imgPhoto-12.1 {Tk_PhotoPutZoomedBlock} hasTeapotPhoto { 567 image create photo p3 -file $teapotPhotoFile 568 set result [list [p3 get 50 50] [p3 get 100 100]] 569 p3 copy p3 -zoom 2 570 lappend result [image width p3] [image height p3] [p3 get 100 100] 571 image delete p3 572 set result 573} {{19 92 192} {169 117 90} 512 512 {19 92 192}} 574 575test imgPhoto-13.1 {check separation of images in different interpreters} { 576 eval image delete [image names] 577 set data { 578 R0lGODlhQgBkAPUAANbWxs7Wxs7OxsbOxsbGxsbGvb3Gvca9vcDAwL21vbW1vbW1tbWtta2t 579 ta2ltaWltaWlraWctaWcrZycrZyUrZSUrZSMrZSMpYyMrYyMpYyEpYSEpYR7pYR7nHp7pYRz 580 pYRynHtzpXtznHtrnHNrnHNjnGtjnGtjlGtalGNalGNSlGNSjFpSlFpKlFpKjFJKjFJCjFI5 581 jEo5jEo5hEoxhEIxhDkphDkhhAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACwAAAAAQgBkAAAG 582 /kCEcEgsGo/IpHLJbDqf0Kh0Sq1ar9isdsvter/gsHhMLpvP6LR6zW673/C4fE6v2+/4vH7P 583 7/v/gIGCg4SFhoeIiYqLjI2Oj5CRkpOUlZaXmJmOBZxXnAQEnKIIBUQJCguoDKkIBgWhpUev 584 CA4TDwgEUpwKERUaHCIiJCQjIiEUQhwqKiwqLjDQMCwoIha3oUO5ESMuLSwtLSIMsU4Tzi4o 585 JBwWFA8ODQoMCkIMq6sNDQ4UFhwlzC4qSGhgkMvCsAoM6E0oAWMCOSUFGrgQcauAgAACSqGa 586 l6SAK1EaJXBA0SIDBw0KBiCg8EtEBgEWYCxoooAigFwIJGgQYQIF/goTAjk6sXhxAwwFnHRO 587 mEmAwoQAIUo8lCWhRgoOElJVkJBQFCwhCRqkYlUE1QMKHEywoBCrQaeIMCgQeOCi3AkYMmRI 588 S5EuxEkN7OApkGDhF4fDxoSVMAFUBAWkRxI0a+XghVAkBSqMsFCBwj4OI0igSKGCdLN0wYKd 589 zGDBwUYhn6YOKUCioQECGk7INpIArQgUKkr87TyhAYIDQxQgLkYsRIcQIDjcgi2Lw8RYKaAz 590 MXCgAs8UJrZGmOA5AkeQBlqRKsIpvYMQDx4S4NCCxIJSKJpFYMIgnPlSF2ygAQWuCUHAAp6x 591 E4EEE5BXQQUWYLABBySoAIMLHBSBWwso/jxwIAoyzMAWEw3AEEJCt6nUwAQagCDCYcCQwJcK 592 6QD3DDQxwNDCCSg9NIAGKpwwgQAOtDADDBbsdkQDIPhkwosDPgDPAg1EAME++1jTnhAKdAnb 593 VAR04EIJFAhwwQs0sBDfE7cZwEAE++yU2joOtDcKE7GUcoIKH6RSmwwnQCZFKAo8cE2es7my 594 HnuxKTDgAA6owEEBjoL3wqRUNDBCCnyRYMFMRSDoWYPvyBPPA738lt1KKTxgpjolrDDiFAWU 595 cAMKE+CipAMRZMDTCSSUQMIJPQHLwWOcrDKBCBpokAIJgmYqQgosxIAOCS8iJEQD7HR2QbMh 596 WCCEK7Ck90Cz/oAFu+YVigpTwTsLyJOcBJ6N6plxRihA3E4cOKTkFCU6FMoAA7wiygAZgURA 597 ekYsEJYFGTSATRccQEMjti8eZsEFFuA7z2WkEJAAl7iEQekEhQHGzgQR4INUKLB8pYAFJaQA 598 KhleKdwAByEkFswHIoxQQn4AcYBvGRosisDICCjQAIMJGnZYBsUd4JEZBIhQwgPzKFwAwggL 599 IHbOQzCtxZ1NL0BlKmmhIOwwHGTg2YMUEBdtKzBfbQWlhMHoHIXBnvABBGE9UMKNMKhgQgnG 600 nNQO0wVQoI4FEohFyr9GzDIYaaPxxWy0rCjKQJUMQvxBaMOgNMQChcU4DAkZ6PoV/hIUoP4i 601 Z7g/YHZHIPXeyWyONgsaCi4AOoLjXP8uhAAvPpCQ2Akr38UpXW60Ij8yPkMmwwj8KAI8QWtQ 602 +eXSixEb37WhcHQBERz2rdZ8leCBBcXNY3XevQ8VG/6+F5CACDYgATlmYYD27aRmLngBNADC 603 GGxxQEAWUJDzqpcctc2DARN4kNRgtJxhnKAFV0kIEhYAJ34IQwUhqkENYFCCE5BmGf9wwWmA 604 5UGgXAAVtfCFMIgRLMbFLQIPYFACcMI7TjQoH2eJQIs2poEMYMAp5XGAvFrBCYS9ImzQG1vT 605 arGTEQhIhE7QjLA+MKDOxClGwuoJtWi0uBIUIxjDSE2wQ4iHl7ywQDjGwZws/NcAlgBjaKQJ 606 JDVuoQBeUeACoFkMcFqgQL1IgxpRSsjsqHA/gy0tHvmAx2z2BxIupaJrnVxCEAAAOw== 607 } 608 interp create x1 609 interp create x2 610 x1 eval {load {} Tk} 611 x2 eval {load {} Tk} 612 x1 eval [list image create photo T1_data -data $data] 613 x2 eval [list image create photo T1_data -data $data] 614 unset data 615 interp delete x1 616 interp delete x2 617} {} 618 619 620test imgPhoto-14.1 {GIF writes work correctly} { 621 set data "R0lGODlhYwA5APcAAAAAAIAAAACAAICAAAAAgIAAgACAgICAgAysnGy8hKzM 622hASs3MTcjAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 623AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 624AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 625AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 626AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 627AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 628AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 629AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 630AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 631AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 632AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 633AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 634AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 635AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 636AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 637AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAMDAwP8AAAD/ 638AP//AAAA//8A/wD//////ywAAAAAYwA5AAAI/wAZCBxIsKDBgwgTKlzIsKHD 639hxAjSpxIsaLFixgzatzIsaPHjyBDihxJsqTJkyhTqlzJsqXLlzBjypxJs6bN 640mzhz6tzJs6fPn0CDCh1KtKhRiwoSKEXAtGlTpUqPGkyagOmCq1edNsWalWkC 641BUSXIuDqFepBqFWtZv3KU+zYrkrBSqT6dgECtjOTbu16NwFHvV3lshRLti/J 642qlgRCE6ZuO9ik4Dt+k0ZVyZiyVIvXr77ODPEy5g9T4zMWfTEzXdNz1VbWvXn 643uqldP1TAOrbshqBb314Y2W7n3Qdpv7UNPCHpycUVbv6dnODy5sqzQldIe8H0 644hciva9/Ovbv37+BzBgEEADs= 645" 646 set photo [image create photo -data $data] 647 set filename [makeFile {} imgPhoto-14.1.gif] 648 removeFile imgPhoto-14.1.gif 649 $photo write $filename -format gif 650 set photo2 [image create photo -file $filename] 651 set result [string equal [$photo data] [$photo2 data]] 652 image delete $photo $photo2 653 catch {file delete -force $filename} 654 set result 655} 1 656test imgPhoto-14.2 {GIF -index handler buffer sizing} -setup { 657 set i [image create photo] 658} -body { 659 # Bug 1458234 makes this crash when trying to access buffers of the 660 # wrong size, caused when the initial frame is not the largest frame. 661 set data { 662 R0lGODlhIAAgAKEAAPkOSQsi7////////yH/C05FVFNDQVBFMi4wAwEAAAAh 663 +QQJMgAAACwGAAYAFAAUAAACEYyPqcvtD6OctNqLs968+68VACH5BAkyAAEA 664 LAMAAwAaABoAAAI0jH+gq+gfmFzQzUsr3gBybn1gIm5kaUaoubbuC8fyTNel 665 Ohv1CSO533u8KrgbUfc5Ci/EAgA7 666 } 667 $i configure -data $data -format {gif -index 2} 668} -cleanup { 669 image delete $i 670} -returnCodes error -result {no image data for this index} 671 672test imgPhoto-14.3 {GIF -index interleaving and small frames} -setup { 673 set i [image create photo] 674} -body { 675 # Interleaved GIFs used to crash us when a smaller subsequent frame 676 # was accessed. 677 $i configure -format {GIF -index 1} -data { 678 R0lGODdhAQAFAPAAAP8AAAAAACwAAAAAAQAFAEACAoRdACwAAAAAAQAEAEACAoRRADs= 679 } 680} -cleanup { 681 image delete $i 682} 683 684test imgPhoto-14.4 {GIF buffer overflow} -setup { 685 set i [image create photo] 686} -body { 687 # This crashes Tk up to 8.4.17 and 8.5.0 688 $i configure -data { 689 R0lGODlhCgAKAPcAAAAAAIAAAACAAICAAAAAgIAAgACAgICAgMDAwP8AAAD/ 690 AP//AAAA//8A/wD//////wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 691 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 692 AAAAMwAAZgAAmQAAzAAA/wAzAAAzMwAzZgAzmQAzzAAz/wBmAABmMwBmZgBm 693 mQBmzABm/wCZAACZMwCZZgCZmQCZzACZ/wDMAADMMwDMZgDMmQDMzADM/wD/ 694 AAD/MwD/ZgD/mQD/zAD//zMAADMAMzMAZjMAmTMAzDMA/zMzADMzMzMzZjMz 695 mTMzzDMz/zNmADNmMzNmZjNmmTNmzDNm/zOZADOZMzOZZjOZmTOZzDOZ/zPM 696 ADPMMzPMZjPMmTPMzDPM/zP/ADP/MzP/ZjP/mTP/zDP//2YAAGYAM2YAZmYA 697 mWYAzGYA/2YzAGYzM2YzZmYzmWYzzGYz/2ZmAGZmM2ZmZmZmmWZmzGZm/2aZ 698 AGaZM2aZZmaZmWaZzGaZ/2bMAGbMM2bMZmbMmWbMzGbM/2b/AGb/M2b/Zmb/ 699 mWb/zGb//5kAAJkAM5kAZpkAmZkAzJkA/5kzAJkzM5kzZpkzmZkzzJkz/5lm 700 AJlmM5lmZplmmZlmzJlm/5mZAJmZM5mZZpmZmZmZzJmZ/5nMAJnMM5nMZpnM 701 mZnMzJnM/5n/AJn/M5n/Zpn/mZn/zJn//8wAAMwAM8wAZswAmcwAzMwA/8wz 702 AMwzM8wzZswzmcwzzMwz/8xmAMxmM8xmZsxmmcxmzMxm/8yZAMyZM8yZZsyZ 703 mcyZzMyZ/8zMAMzMM8zMZszMmczMzMzM/8z/AMz/M8z/Zsz/mcz/zMz///8A 704 AP8AM/8AZv8Amf8AzP8A//8zAP8zM/8zZv8zmf8zzP8z//9mAP9mM/9mZv9m 705 mf9mzP9m//+ZAP+ZM/+ZZv+Zmf+ZzP+Z///MAP/MM//MZv/Mmf/MzP/M//// 706 AP//M///Zv//mf//zP///yH5BAEAABAALAAAAAAKAAoAABUSAAD/HEiwoMGD 707 CBMqXMiwYcKAADs= 708 } 709} -cleanup { 710 image delete $i 711} -returnCodes error -result {malformed image} 712 713test imgPhoto-15.1 {photo images can fail to allocate memory gracefully} \ 714 {nonPortable} { 715 # This is not portable to very large machines with more around 716 # 3GB of free memory available... 717 list [catch {image create photo -width 32000 -height 32000} msg] $msg 718} {1 {not enough free memory for image buffer}} 719 720test imgPhoto-16.1 {copying to self doesn't access freed memory} { 721 # Bug 877950 makes this crash when trying to copy out of a deallocated area 722 set i [image create photo] 723 $i put red -to 0 0 1000 1000 724 $i copy $i -from 0 0 1000 1000 -to 500 0 725 image delete $i 726} {} 727 728destroy .c 729eval image delete [image names] 730 731# cleanup 732removeFile README-imgPhoto 733::tcltest::cleanupTests 734return 735
