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