summaryrefslogtreecommitdiffstats
path: root/tests/imgPhoto.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/imgPhoto.test')
-rw-r--r--tests/imgPhoto.test1336
1 files changed, 1277 insertions, 59 deletions
diff --git a/tests/imgPhoto.test b/tests/imgPhoto.test
index 34107cc..cfc8c61 100644
--- a/tests/imgPhoto.test
+++ b/tests/imgPhoto.test
@@ -2,22 +2,92 @@
# procedures in the file tkImgPhoto.c. It is organized in the standard fashion
# for Tcl tests.
#
-# Copyright (c) 1994 The Australian National University
-# Copyright (c) 1994-1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
-# Copyright (c) 2002-2008 Donal K. Fellows
+# Copyright © 1994 The Australian National University
+# Copyright © 1994-1997 Sun Microsystems, Inc.
+# Copyright © 1998-1999 Scriptics Corporation.
+# Copyright © 2002-2008 Donal K. Fellows
# All rights reserved.
#
# Author: Paul Mackerras (paulus@cs.anu.edu.au)
+#
+# This file is somewhat caothic: the order of the tests does not
+# really follow the order of the corresponding functions in
+# tkImgPhoto.c. Probably, because early versions had only a few tests
+# and over time test cases were added in bits and pieces.
+# To be noted, also, that this file is not complete: large portions of
+# code in tkImgPhoto.c have no test coverage.
+#
+# To help keeping the overview, the table below lists where to find
+# tests for each of the functions in tkImgPhoto.c. The function are
+# listed in the order as they appear in the source file.
+#
+
+#
+# Function name Tests for function
+#--------------------------------------------------------------------------
+# PhotoFormatThreadExitProc no tests
+# Tk_Create*PhotoImageFormat no tests
+# ImgPhotoCreate imgPhoto-2.*
+# ImgPhotoCmd imgPhoto-4.*, imgPhoto-17.*
+# GetExtension: no tests
+# ParseSubcommandOptions: imgPhoto-1.*
+# ImgPhotoConfigureModel: imgPhoto-3.*, imgPhoto-15.*
+# toggleComplexAlphaIfNeeded: no tests
+# ImgPhotoDelete: imgPhoto-8.*
+# ImgPhotoCmdDeleteProc: imgPhoto-9.*
+# ImgPhotoSetSize: no tests
+# MatchFileFormat: imgPhoto-18.*
+# MatchSringFormat: imgPhoto-19.*
+# Tk_FindPhoto: imgPhoto-11.*
+# Tk_PhotoPutBlock: imgPhoto-10.*, imgPhoto-16.*
+# Tk_PhotoPutZoomedBlock: imgPhoto-12.*
+# Tk_DitherPhoto: no tets
+# Tk_PhotoBlank: no tests
+# Tk_PhotoExpand: no tests
+# Tk_PhotoGetSize: no tests
+# Tk_PhotoSetSize: no tests
+# TkGetPhotoValidRegion: no tests
+# ImgGetPhoto: no tests
+# Tk_PhotoGetImage no tests
+# ImgPostscriptPhoto no tests
+# Tk_PhotoPutBlock_NoComposite no tests, probably none needed
+# Tk_PhotoPutZoomedBlock_NoComposite no tests, probably none needed
+# Tk_PhotoExpand_Panic no tests, probably none needed
+# Tk_PhotoPutBlock_Panic no tests, probably none needed
+# Tk_PhotoPutZoomedBlock_Panic no tests, probably none needed
+# Tk_PhotoSetSize_Panic no tests, probably none needed
+# Tk_PhotoGetMetadata: imgPhoto-21.*
+# Tk_PhotoSetMetadata: imgPhoto-22.*
+#--------------------------------------------------------------------------
+#
+
+#
+# Some tests are not specific to a function in tkImgPhoto.c. They are:
+#
+
+#
+# Test name(s) Description
+#--------------------------------------------------------------------------
+# imgPhoto-5.* Do not really belong to this file. ImgPhotoGet and
+# ImgPhotoFree are defined in tkImgPhInstance.c.
+# imgPhoto-6.* Do not really belong to this file. ImgPhotoDisplay
+# is defined in tkImgPhInstance.c.
+# imgPhoto-7.* Do not really belong to this file. ImgPhotoFree is
+# defined in tkImgPhInstance.c.
+# imgPhoto-13.* Tests for separation in different interpreters
+# imgPhoto-14.* Test GIF format. Would belong to imgGIF.test
+# - which does not exist.
+#
+
package require tcltest 2.2
namespace import ::tcltest::*
tcltest::configure {*}$argv
tcltest::loadTestedCommands
-# Used for 4.65 - 4.73 tests
-# Now for some heftier testing, checking that setting and resetting of pixels'
-# transparency status doesn't "leak" with any one-off errors.
+#
+# Used for imgPhoto-4.65 - imgPhoto-4.73
+#
proc foreachPixel {img xVar yVar script} {
upvar 1 $xVar x $yVar y
set width [image width $img]
@@ -56,6 +126,10 @@ set README [makeFile {
} README-imgPhoto]
set teapotPhotoFile [file join [file dirname [info script]] teapot.ppm]
+set transpTeapotPhotoFile [file join [file dirname [info script]] teapotTransparent.png]
+
+testConstraint needsTcl867 [package vsatisfies [package provide Tcl] 8.6.7-]
+
test imgPhoto-1.1 {options for photo images} -body {
image create photo photo1 -width 79 -height 83
@@ -105,7 +179,26 @@ test imgPhoto-1.10 {options for photo images - error case} -body {
test imgPhoto-1.11 {options for photo images - error case} -body {
image create photo photo1 -format
} -returnCodes error -result {value for "-format" missing}
-
+test imgPhoto-1.12 {option -alpha, normal use} -setup {
+ image create photo photo1
+} -body {
+ photo1 put "white" -to 0 0
+ photo1 transparency get 0 0 -alpha
+} -cleanup {
+ imageCleanup
+} -result 255
+test imgPhoto-1.13 {option -withalpha, normal use} -setup {
+ image create photo photo1
+} -body {
+ photo1 put {{blue green}}
+ photo1 get 1 0 -withalpha
+} -cleanup {
+ imageCleanup
+} -result {0 128 0 255}
+test imgPhoto-1.14 {options for photo images - error case} -body {
+ image create photo photo1 -metadata
+} -returnCodes error -result {value for "-metadata" missing}
+
test imgPhoto-2.1 {ImgPhotoCreate procedure} -setup {
imageCleanup
} -body {
@@ -158,7 +251,37 @@ test imgPhoto-3.3 {ImgPhotoConfigureModel procedure} -setup {
destroy .c
image delete photo1
} -result {256 256 {10 10 266 266} {300 10 556 266}}
-
+test imgPhoto-3.4 {ImgPhotoConfigureModel: -data <ppm>} -setup {
+ image create photo photo1 -file $teapotPhotoFile
+ image create photo photo2
+} -body {
+ photo2 configure -data [photo1 data -format ppm -from 100 100 120 120]
+ list [image width photo2] [image height photo2]
+} -cleanup {
+ imageCleanup
+} -result {20 20}
+# This testcase fails with Tcl < 8.6.7, due to [25842c]
+test imgPhoto-3.5 {ImgPhotoConfigureModel: -data <png>} -constraints {
+ needsTcl867
+} -setup {
+ image create photo photo1 -file $teapotPhotoFile
+ image create photo photo2
+} -body {
+ photo2 configure -data [photo1 data -format png -from 120 120 140 140]
+ list [image width photo2] [image height photo2]
+} -cleanup {
+ imageCleanup
+} -result {20 20}
+test imgPhoto-3.6 {ImgPhotoConfigureModel: -data <default>} -setup {
+ image create photo photo1 -file $teapotPhotoFile
+ image create photo photo2
+} -body {
+ photo2 configure -data [photo1 data -from 80 90 100 110]
+ list [image width photo2] [image height photo2]
+} -cleanup {
+ imageCleanup
+} -result {20 20}
+
test imgPhoto-4.1 {ImgPhotoCmd procedure} -setup {
image create photo photo1
} -body {
@@ -201,7 +324,7 @@ test imgPhoto-4.6 {ImgPhotoCmd procedure: configure option} -setup {
llength [photo1 configure]
} -cleanup {
image delete photo1
-} -result 7
+} -result 8
test imgPhoto-4.7 {ImgPhotoCmd procedure: configure option} -setup {
image create photo photo1
} -body {
@@ -341,14 +464,17 @@ test imgPhoto-4.21 {ImgPhotoCmd procedure: copy option} -setup {
} -cleanup {
image delete photo1 photo2
} -result {256 256 49 51 49 51 49 51 10 51 10 10}
+# tests for <imageName> data: imgPhoto-4.
test imgPhoto-4.22 {ImgPhotoCmd procedure: get option} -setup {
image create photo photo1
} -body {
- photo1 read $teapotPhotoFile
- list [photo1 get 100 100] [photo1 get 150 100] [photo1 get 100 150]
+ photo1 read $transpTeapotPhotoFile
+ list [photo1 get 100 100 -withalpha] \
+ [photo1 get 150 100 -withalpha] \
+ [photo1 get 100 150] [photo1 get 150 150]
} -cleanup {
image delete photo1
-} -result {{169 117 90} {172 115 84} {35 35 35}}
+} -result {{175 71 0 162} {179 73 0 168} {14 8 0} {0 0 0}}
test imgPhoto-4.23 {ImgPhotoCmd procedure: get option} -setup {
image create photo photo1
} -body {
@@ -366,10 +492,12 @@ test imgPhoto-4.24 {ImgPhotoCmd procedure: get option} -setup {
test imgPhoto-4.25 {ImgPhotoCmd procedure: get option} -setup {
image create photo photo1
} -body {
- photo1 get
+ photo1 get 0
} -cleanup {
image delete photo1
-} -returnCodes error -result {wrong # args: should be "photo1 get x y"}
+} -returnCodes error -result \
+ {wrong # args: should be "photo1 get x y ?-withalpha?"}
+# more test for image get: 4.101-4.102
test imgPhoto-4.26 {ImgPhotoCmd procedure: put option} -setup {
image create photo photo1
} -body {
@@ -383,22 +511,28 @@ test imgPhoto-4.27 {ImgPhotoCmd procedure: put option} -setup {
photo1 put {{white} {white white}}
} -returnCodes error -cleanup {
image delete photo1
-} -result {all elements of color list must have the same number of elements}
+} -result {invalid row # 1: all rows must have the same number of elements}
test imgPhoto-4.28 {ImgPhotoCmd procedure: put option} -setup {
image create photo photo1
} -body {
photo1 put {{blahgle}}
} -cleanup {
image delete photo1
-} -returnCodes error -result {can't parse color "blahgle"}
+} -returnCodes error -result {invalid color name "blahgle"}
test imgPhoto-4.29 {ImgPhotoCmd procedure: put option} -setup {
image create photo photo1
} -body {
- photo1 put -to 10 10 20 20 {{white}}
+ # SB: odd thing - this test passed with tk 8.6.6, even if the data
+ # is in the wrong position:
+ #photo1 put -to 10 10 20 20 {{white}}
+
+ # this is how it's supposed to be:
+ photo1 put {{white}} -to 10 10 20 20
photo1 get 19 19
} -cleanup {
image delete photo1
} -result {255 255 255}
+# more tests for image put: 4.90-4.100
test imgPhoto-4.30 {ImgPhotoCmd procedure: read option} -setup {
image create photo photo1
} -body {
@@ -412,7 +546,7 @@ test imgPhoto-4.31 {ImgPhotoCmd procedure: read option} -setup {
photo1 read $teapotPhotoFile -zoom 2
} -returnCodes error -cleanup {
image delete photo1
-} -result {unrecognized option "-zoom": must be -format, -from, -shrink, or -to}
+} -result {unrecognized option "-zoom": must be -format, -from, -metadata, -shrink, or -to}
test imgPhoto-4.32 {ImgPhotoCmd procedure: read option} -setup {
image create photo photo1
} -body {
@@ -472,6 +606,7 @@ test imgPhoto-4.39 {ImgPhotoCmd procedure: write option} -setup {
} -cleanup {
image delete photo1
} -returnCodes error -result {image file format "bogus" is unknown}
+# more tests on "imageName write": imgPhoto-17.*
test imgPhoto-4.40 {ImgPhotoCmd procedure: transparency option} -setup {
image create photo photo1
} -body {
@@ -485,21 +620,21 @@ test imgPhoto-4.41 {ImgPhotoCmd procedure: transparency get option} -setup {
photo1 transparency get
} -returnCodes error -cleanup {
image delete photo1
-} -result {wrong # args: should be "photo1 transparency get x y"}
+} -result {wrong # args: should be "photo1 transparency get x y ?-option?"}
test imgPhoto-4.42 {ImgPhotoCmd procedure: transparency get option} -setup {
image create photo photo1
} -body {
photo1 transparency get 0
} -returnCodes error -cleanup {
image delete photo1
-} -result {wrong # args: should be "photo1 transparency get x y"}
+} -result {wrong # args: should be "photo1 transparency get x y ?-option?"}
test imgPhoto-4.43 {ImgPhotoCmd procedure: transparency get option} -setup {
image create photo photo1
} -body {
- photo1 transparency get 0 0 0
+ photo1 transparency get 0 0 0 -alpha
} -returnCodes error -cleanup {
image delete photo1
-} -result {wrong # args: should be "photo1 transparency get x y"}
+} -result {wrong # args: should be "photo1 transparency get x y ?-option?"}
test imgPhoto-4.44 {ImgPhotoCmd procedure: transparency get option} -setup {
image create photo photo1
} -body {
@@ -559,34 +694,39 @@ test imgPhoto-4.51 {ImgPhotoCmd procedure: transparency get option} -setup {
} -cleanup {
image delete photo1
} -result 1
+# more tests for transparency get: 4.65, 4.66, 4.76-4.81
test imgPhoto-4.52 {ImgPhotoCmd procedure: transparency set option} -setup {
image create photo photo1
} -body {
photo1 transparency set
} -returnCodes error -cleanup {
image delete photo1
-} -result {wrong # args: should be "photo1 transparency set x y boolean"}
+} -result \
+ {wrong # args: should be "photo1 transparency set x y newVal ?-option?"}
test imgPhoto-4.53 {ImgPhotoCmd procedure: transparency set option} -setup {
image create photo photo1
} -body {
photo1 transparency set 0
} -returnCodes error -cleanup {
image delete photo1
-} -result {wrong # args: should be "photo1 transparency set x y boolean"}
+} -result \
+ {wrong # args: should be "photo1 transparency set x y newVal ?-option?"}
test imgPhoto-4.54 {ImgPhotoCmd procedure: transparency set option} -setup {
image create photo photo1
} -body {
photo1 transparency set 0 0
} -returnCodes error -cleanup {
image delete photo1
-} -result {wrong # args: should be "photo1 transparency set x y boolean"}
+} -result \
+ {wrong # args: should be "photo1 transparency set x y newVal ?-option?"}
test imgPhoto-4.55 {ImgPhotoCmd procedure: transparency set option} -setup {
image create photo photo1
} -body {
- photo1 transparency set 0 0 0 0
+ photo1 transparency set 0 0 0 0 -alpha
} -returnCodes error -cleanup {
image delete photo1
-} -result {wrong # args: should be "photo1 transparency set x y boolean"}
+} -result \
+ {wrong # args: should be "photo1 transparency set x y newVal ?-option?"}
test imgPhoto-4.56 {ImgPhotoCmd procedure: transparency set option} -setup {
image create photo photo1
} -body {
@@ -603,6 +743,7 @@ test imgPhoto-4.57 {ImgPhotoCmd procedure: transparency set option} -setup {
} -returnCodes error -result {expected integer but got "bogus"}
test imgPhoto-4.58 {ImgPhotoCmd procedure: transparency set option} -setup {
image create photo photo1
+ photo1 put blue
} -body {
photo1 transparency set 0 0 bogus
} -cleanup {
@@ -654,6 +795,7 @@ test imgPhoto-4.64 {ImgPhotoCmd procedure: transparency set option} -setup {
} -cleanup {
image delete photo1
} -result 1
+# more tests for transparency set: 4.67, 4.68, 4.82-4.89
# Now for some heftier testing, checking that setting and resetting of pixels'
# transparency status doesn't "leak" with any one-off errors.
test imgPhoto-4.65 {ImgPhotoCmd procedure: transparency get option} -setup {
@@ -776,7 +918,7 @@ test imgPhoto-4.75 {<photo> read command: filename starting with '-'} -body {
image delete photo1
file delete ./-teapotPhotoFile
} -result {}
-test imgPhoto-4.76 {ImgPhotoCmd procedure: copy to same image} -setup {
+test imgPhoto-4.75.1 {ImgPhotoCmd procedure: copy to same image} -setup {
imageCleanup
image create photo photo1 -file $teapotPhotoFile
} -body {
@@ -786,7 +928,405 @@ test imgPhoto-4.76 {ImgPhotoCmd procedure: copy to same image} -setup {
} -cleanup {
imageCleanup
} -result {}
-
+test imgPhoto-4.76 {ImgPhotoCmd, transparency get: too many options} -setup {
+ image create photo photo1
+} -body {
+ photo1 put white -to 0 0 1 1
+ photo1 transparency get 0 0 -alpha -bogus
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result \
+ {wrong # args: should be "photo1 transparency get x y ?-option?"}
+test imgPhoto-4.77 {ImgPhotoCmd, transparency get: invalid option} -setup {
+ image create photo photo1
+} -body {
+ photo1 put white -to 0 0 1 1
+ photo1 transparency get 0 0 -bogus
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result \
+ {unrecognized option "-bogus": must be -alpha}
+test imgPhoto-4.78 {ImgPhotoCmd, transparency get: normal use} -setup {
+ image create photo photo1
+} -body {
+ photo1 put white -to 0 0 1 1
+ set result [photo1 transparency get 0 0]
+ lappend result [photo1 transparency get 0 0 -alpha]
+} -cleanup {
+ imageCleanup
+} -result {0 255}
+test imgPhoto-4.79 {ImgPhotoCmd, transparency get: no option} -setup {
+ image create photo photo1 -file $transpTeapotPhotoFile
+ set result {}
+} -body {
+ set pixelCoords {{156 239} {76 207} {153 213} {139 43} {75 112}}
+ foreach coord $pixelCoords {
+ lappend result [photo1 transparency get {*}$coord]
+ }
+ set result
+} -cleanup {
+ imageCleanup
+} -result {0 1 0 0 0}
+# test imgPhoto-4.80: deleted (was transparency get: -boolean)
+test imgPhoto-4.81 {ImgPhotoCmd, transparency get: -alpha} -setup {
+ image create photo photo1 -file $transpTeapotPhotoFile
+ set result {}
+} -body {
+ set pixelCoords {{156 239} {76 207} {153 213} {139 43} {75 112}}
+ foreach coord $pixelCoords {
+ lappend result [photo1 transparency get {*}$coord -alpha]
+ }
+ set result
+} -cleanup {
+ imageCleanup
+} -result {255 0 1 254 206}
+test imgPhoto-4.82 {ImgPhotoCmd, transparency set: too many opts} -setup {
+ image create photo photo1
+} -body {
+ photo1 transparency set 0 0 -alpha -bogus 1
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result \
+ {wrong # args: should be "photo1 transparency set x y newVal ?-option?"}
+test imgPhoto-4.83 {ImgPhotoCmd, transparency set: invalid opt} -setup {
+ image create photo photo1 -data black
+} -body {
+ photo1 transparency set 0 0 0 -bogus
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result \
+ {unrecognized option "-bogus": must be -alpha}
+test imgPhoto-4.84 {ImgPhotoCmd, transparency set: invalid newVal} -setup {
+ image create photo photo1 -data white
+} -body {
+ photo1 transparency set 0 0 bogus -alpha
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result {expected integer but got "bogus"}
+test imgPhoto-4.85 {ImgPhotoCmd, transparency set: invalid newVal} -setup {
+ image create photo photo1 -data red
+} -body {
+ photo1 transparency set 0 0 -1 -alpha
+} -returnCodes error -result \
+ {invalid alpha value "-1": must be integer between 0 and 255}
+test imgPhoto-4.86 {ImgPhotoCmd, transparency set: invalid newVal} -setup {
+ image create photo photo1 -data green
+} -body {
+ photo1 transparency set 0 0 256 -alpha
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result \
+ {invalid alpha value "256": must be integer between 0 and 255}
+test imgPhoto-4.87 {ImgPhotoCmd, transparency set: no opt} -setup {
+ image create photo photo1
+} -body {
+ photo1 put white -to 0 0 2 1
+ photo1 transparency set 0 0 0
+ photo1 transparency set 1 0 1
+ list [photo1 transparency get 0 0 -alpha] \
+ [photo1 transparency get 1 0 -alpha]
+} -cleanup {
+ imageCleanup
+} -result {255 0}
+# deleted: test imgPhoto-4.88 {ImgPhotoCmd, transparency set: -boolean}
+test imgPhoto-4.89 {ImgPhotoCmd, transparency set: -alpha} -setup {
+ image create photo photo1
+} -body {
+ photo1 put white -to 0 0 2 2
+ photo1 transparency set 0 0 0 -alpha
+ photo1 transparency set 1 0 1 -alpha
+ photo1 transparency set 0 1 254 -alpha
+ photo1 transparency set 1 1 255 -alpha
+ list [photo1 transparency get 0 0] [photo1 transparency get 1 0] \
+ [photo1 transparency get 0 1] [photo1 transparency get 1 1]
+} -cleanup {
+ imageCleanup
+} -result {1 0 0 0}
+test imgPhoto-4.90 {ImgPhotoCmd put: existing but not allowed opt} -setup {
+ image create photo photo1
+} -body {
+ photo1 put yellow -from 0 0 1 1
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result \
+ {unrecognized option "-from": must be -format, -metadata, or -to}
+test imgPhoto-4.91 {ImgPhotoCmd put: invalid option} -setup {
+ image create photo photo1
+} -body {
+ photo1 put {{0 1 2 3}} -bogus x
+} -returnCodes error -result \
+ {unrecognized option "-bogus": must be -format, -metadata, or -to}
+test imgPhoto-4.92 {ImgPhotocmd put: missing data} -setup {
+ image create photo photo1
+} -body {
+ photo1 put -to 0 0
+} -returnCodes error -result \
+ {wrong # args: should be "photo1 put data ?-option value ...?"}
+test imgPhoto-4.93 {ImgPhotoCmd put: data in ppm format} -setup {
+ image create photo photo1 -file $teapotPhotoFile
+ image create photo photo2
+} -body {
+ set imgdata [photo1 data -format ppm]
+ photo2 put $imgdata -format ppm
+ set result {}
+ if {[image width photo1] != [image width photo2] \
+ || [image height photo1] != [image height photo2]} {
+ lappend result [list [image width photo2] [image height photo2]]
+ } else {
+ lappend result 1
+ }
+ foreach point {{206 125} {67 12} {13 46} {19 184}} {
+ if {[photo1 get {*}$point] ne [photo2 get {*}$point]} {
+ lappend result [photo2 get {*}$point]
+ } else {
+ lappend result 1
+ }
+ }
+ set result
+} -cleanup {
+ imageCleanup
+} -result {1 1 1 1 1}
+test imgPhoto-4.94 {ImgPhotoCmd put: unknown format} -setup {
+ image create photo photo1
+} -body {
+ photo1 put {no real data} -format bogus
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result {image format "bogus" is not supported}
+test imgPhoto-4.95 {ImgPhotoCmd put: default fmt, invalid data} -setup {
+ image create photo photo1
+} -body {
+ photo1 put {{red green blue} {red " blue}}
+ #"
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result {unmatched open quote in list}
+test imgPhoto-4.96 {ImgPhotoCmd put: "default" handler is selected} -setup {
+ image create photo photo1
+ image create photo photo2
+ set imgData {{{1 2 3 4} {5 6 7 8} {9 10 11 12}}
+ {{13 14 15 15} {17 18 19 20} {21 22 23 24}}}
+} -body {
+ photo1 put $imgData
+ photo2 put $imgData -format default
+ set result {}
+ lappend result [list [image width photo1] [image height photo1]]
+ lappend result [list [image width photo2] [image height photo2]]
+ lappend result [string equal \
+ [photo1 data -format "default -colorformat rgba"] \
+ [photo2 data -format "default -colorformat rgba"]]
+ set result
+} -cleanup {
+ imageCleanup
+ unset result
+ unset imgData
+} -result {{3 2} {3 2} 1}
+test imgPhoto-4.97 {ImgPhotoCmd put: image size} -setup {
+ image create photo photo1
+} -body {
+ photo1 put {{red green blue} {blue red green}}
+ list [image width photo1] [image height photo1]
+} -cleanup {
+ imageCleanup
+} -result {3 2}
+test imgPhoto-4.98 {ImgPhotoCmd put: -to with 2 coords} -setup {
+ image create photo photo1
+} -body {
+ photo1 put {{"alice blue" "blanched almond"}
+ {"deep sky blue" "ghost white"}
+ {#AABBCC #AABBCCDD}} -to 5 6
+ list [image width photo1] [image height photo1]
+} -cleanup {
+ imageCleanup
+} -result {7 9}
+test imgPhoto-4.99 {ImgPhotoCmd put: -to with 4 coords} -setup {
+ image create photo photo1
+} -body {
+ photo1 put {{#123 #456 #678} {#9AB #CDE #F01}} -to 1 2 20 21
+ set result {}
+ lappend result [photo1 get 19 20 -withalpha]
+ lappend result [string equal \
+ [photo1 data -from 1 2 4 4] [photo1 data -from 4 2 7 4]]
+ lappend result [string equal \
+ [photo1 data -from 10 12 13 14] [photo1 data -from 16 16 19 18]]
+ set result
+} -cleanup {
+ imageCleanup
+} -result {{17 34 51 255} 1 1}
+test imgPhoto-4.100 {ImgPhotoCmd put: no changes on empty data} -setup {
+ image create photo photo1
+} -body {
+ photo1 put {{brown blue} {cyan coral}}
+ set imgData [photo1 data]
+ photo1 put {}
+ string equal $imgData [photo1 data]
+} -cleanup {
+ imageCleanup
+} -result 1
+test imgPhoto-4.101 {ImgPhotoCmd get: too many args} -setup {
+ image create photo photo1
+} -body {
+ photo1 get 0 0 -withalpha bogus
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result \
+ {wrong # args: should be "photo1 get x y ?-withalpha?"}
+test imgPhoto-4.102 {ImgPhotoCmd get: invalid option} -setup {
+ image create photo photo1
+} -body {
+ photo1 get 0 0 -bogus
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result \
+ {unrecognized option "-bogus": must be -withalpha}
+test imgPhoto-4.103 {ImgPhotoCmd data: accepted opts} -setup {
+ image create photo photo1 -data black
+} -body {
+ photo1 data -format default -from 0 0 -grayscale -background blue
+} -cleanup {
+ imageCleanup
+} -result {{#000000}}
+test imgPhoto-4.104 {ImgPhotoCmd data: existing but not accepted opt} -setup {
+ image create photo photo1
+} -body {
+ photo1 data -to
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result \
+{unrecognized option "-to": must be -background, -format, -from, -grayscale, or -metadata}
+test imgPhoto-4.105 {ImgPhotoCmd data: invalid option} -setup {
+ image create photo photo1
+} -body {
+ photo1 data -bogus
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result \
+{unrecognized option "-bogus": must be -background, -format, -from, -grayscale, or -metadata}
+test imgPhoto-4.106 {ImgPhotoCmd data: extra arg before options} -setup {
+ image create photo photo1
+} -body {
+ photo1 data bogus -grayscale
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result \
+ {wrong # args: should be "photo1 data ?-option value ...?"}
+test imgPhoto-4.107 {ImgPhotoCmd data: extra arg after options} -setup {
+ image create photo photo1
+} -body {
+ photo1 data -format default bogus
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result \
+ {wrong # args: should be "photo1 data ?-option value ...?"}
+test imgPhoto-4.108 {ImgPhotoCmd data: invalid -from coords #1} -setup {
+ image create photo photo1 -data blue
+} -body {
+ photo1 data -from 2 0
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result \
+ {coordinates for -from option extend outside image}
+test imgPhoto-4.109 {ImgPhotoCmd data: invalid -from coords #2} -setup {
+ image create photo photo1 -data blue
+} -body {
+ photo1 data -from 0 2
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result \
+ {coordinates for -from option extend outside image}
+test imgPhoto-4.110 {ImgPhotoCmd data: invalid -from coords #3} -setup {
+ image create photo photo1 -data blue
+} -body {
+ photo1 data -from 0 0 2 1
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result \
+ {coordinates for -from option extend outside image}
+test imgPhoto-4.111 {ImgPhotoCmd data: invalid -from coords #4} -setup {
+ image create photo photo1 -data blue
+} -body {
+ photo1 data -from 0 0 1 2
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result \
+ {coordinates for -from option extend outside image}
+test imgPhoto-4.112 {ImgPhotoCmd data: -from with 2 coords} -setup {
+ image create photo photo1 -data {
+ {black black black black black}
+ {white white white white white}
+ {green green green green green}}
+} -body {
+ set imgData [photo1 data -from 2 1]
+ list [llength [lindex $imgData 0]] [llength $imgData]
+} -cleanup {
+ imageCleanup
+ unset imgData
+} -result {3 2}
+test imgPhoto-4.113 {ImgPhotoCmd data: default is rgb format} -setup {
+ image create photo photo1 -data red
+} -body {
+ photo1 data
+} -cleanup {
+ imageCleanup
+} -result {{#ff0000}}
+test imgPhoto-4.114 {ImgPhotoCmd data: unknown format} -setup {
+ image create photo photo1
+} -body {
+ photo1 data -format bogus
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result {image string format "bogus" is unknown}
+test imgPhoto-4.115 {ImgPhotoCmd data: rgb colorformat} -setup {
+ image create photo photo1 -data {{red#a green#b} {blue#c white}}
+} -body {
+ photo1 data -format {default -colorformat rgb}
+} -result {{#ff0000 #008000} {#0000ff #ffffff}}
+test imgPhoto-4.116 {ImgPhotoCmd data: rgba colorformat} -setup {
+ image create photo photo1 -data {{red green} {blue white}}
+} -body {
+ photo1 data -format {default -colorformat rgba}
+} -result {{#ff0000ff #008000ff} {#0000ffff #ffffffff}}
+test imgPhoto-4.117 {ImgPhotoCmd data: list colorformat} -setup {
+ image create photo photo1 -data {{red#a green} {blue#c white#d}}
+} -body {
+ photo1 data -format {default -colorformat list}
+} -result {{{255 0 0 170} {0 128 0 255}} {{0 0 255 204} {255 255 255 221}}}
+# This testcase fails with Tcl < 8.6.7, due to [25842c]
+test imgPhoto-4.118 {ImgPhotoCmd data: using data for new image
+ results in same image as orignial } -constraints {
+ needsTcl867
+} -setup {
+ image create photo teapot -file $teapotPhotoFile
+ teapot copy teapot -from 50 60 70 80 -shrink
+ image create photo teapotTransp -file $transpTeapotPhotoFile
+ teapotTransp copy teapotTransp -from 100 110 120 130 -shrink
+ image create photo photo1
+} -body {
+ set result {}
+ # We don't test gif here, as there seems to be a problem with
+ # <imgName> data and gif format ("too many colors", probably a bug)
+ foreach fmt {ppm png {default -colorformat rgba} \
+ {default -colorformat list}} {
+ set imgData [teapotTransp data -format $fmt]
+ photo1 blank
+ photo1 put $imgData
+ if { ! [string equal [photo1 data] [teapotTransp data]]} {
+ lappend result $fmt
+ }
+ }
+ set imgData [teapot data -format default]
+ photo1 blank
+ photo1 put $imgData
+ if { ! [string equal [photo1 data] [teapot data]]} {
+ lappend result default
+ }
+ set result
+} -cleanup {
+ unset imgData
+ unset result
+ imageCleanup
+} -result {}
+
test imgPhoto-5.1 {ImgPhotoGet/Free procedures, shared instances} -setup {
destroy .c
pack [canvas .c]
@@ -946,7 +1486,6 @@ test imgPhoto-10.4 {Tk_ImgPhotoPutBlock, empty image} -setup {
} -cleanup {
imageCleanup
} -result {0 0}
-
test imgPhoto-11.1 {Tk_FindPhoto} -setup {
imageCleanup
} -body {
@@ -1248,11 +1787,112 @@ test imgPhoto-17.3 {photo write: format guessing from filename} -setup {
image delete $i
catch {removeFile $f}
} -result "P6\n"
+test imgPhoto-17.4 {photo write: default format not supported} -setup {
+ image create photo photo1 -data {{blue blue} {red red} {green green}}
+ set f [makeFile {} test.txt]
+} -body {
+ photo1 write $f -format default
+} -cleanup {
+ imageCleanup
+ catch {removeFile $f}
+ unset f
+} -returnCodes error -result \
+ {image file format "default" has no file writing capability}
+test imgPhoto-17.5 {photo write: file with extension .default} -setup {
+ image create photo photo1 -data {{black}}
+ set f [makeFile {} test.default]
+} -body {
+ photo1 write $f
+} -cleanup {
+ imageCleanup
+ catch {removeFile $f}
+ unset f
+} -returnCodes error -result \
+ {image file format "default" has no file writing capability}
+
+test imgPhoto-18.1 {MatchFileFormat: "default" format not supported} -setup {
+ image create photo photo1
+ set f [makeFile {} test.txt]
+} -body {
+ photo1 read $f -format default
+} -cleanup {
+ imageCleanup
+ catch {removeFile $f}
+ unset f
+} -returnCodes error -result {-file option isn't supported for default images}
+
+test imgPhoto-19.1 {MatchStringFormat: with "-format default"} -setup {
+ image create photo photo1
+} -body {
+ photo1 put {{red blue red} {yellow green yellow}} -format default
+ list [image width photo1] [image height photo1]
+} -cleanup {
+ imageCleanup
+} -result {3 2}
+test imgPhoto-19.2 {MatchStringFormat: without -format option,
+ default fmt} -body {
+ image create photo photo1
+ photo1 put {{red} {green}}
+ list [image width photo1] [image height photo1]
+} -cleanup {
+ imageCleanup
+} -result {1 2}
+test imgPhoto-19.3 {MatchStringFormat: "-format ppm"} -setup {
+ image create photo photo1
+ image create photo photo2
+ photo2 put {cyan cyan}
+ set imgData [photo2 data -format ppm]
+} -body {
+ photo1 put $imgData -format ppm
+ list [image width photo1] [image height photo1]
+} -cleanup {
+ unset imgData
+ imageCleanup
+} -result {1 2}
+test imgPhoto-19.4 {MatchStringFormat: ppm fmt, without opt} -setup {
+ image create photo photo1 -file $teapotPhotoFile
+ image create photo photo2
+} -body {
+ set imgData [photo1 data -format ppm]
+ photo2 put $imgData
+ list [image width photo2] [image height photo2]
+} -cleanup {
+ imageCleanup
+ unset imgData
+} -result {256 256}
+test imgPhoto-19.5 {MatchStirngFormat: unknown -format} -setup {
+ image create photo photo1
+} -body {
+ photo1 put {} -format bogus
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result {image format "bogus" is not supported}
+test imgPhoto-19.6 {MatchStringFormat: invalid data for default} -setup {
+ image create photo photo1
+} -body {
+ photo1 put bogus
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result {invalid color name "bogus"}
+test imgPhoto-19.7 {MatchStringFormat: invalid data for default} -setup {
+ image create photo photo1
+} -body {
+ photo1 put bogus -format dEFault
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result {invalid color name "bogus"}
+test imgPhoto-19.8 {MatchStirngFormat: invalid data for gif} -setup {
+ image create photo photo1
+} -body {
+ photo1 put bogus -format giF
+} -cleanup {
+ imageCleanup
+} -returnCodes error -result {couldn't recognize image data}
# Reject corrupted or truncated image [Bug b601ce3ab1].
-# WARNING - tests 18.1-18.9 will cause a segfault on 8.5.19 and lower,
+# WARNING - tests 20.1-20.9 will cause a segfault on 8.5.19 and lower,
# and on 8.6.6 and lower.
-test imgPhoto-18.1 {Reject corrupted GIF (binary string)} -setup {
+test imgPhoto-20.1 {Reject corrupted GIF (binary string)} -setup {
set data [binary decode base64 {
R0lGODlhAAQABP8zM/8z/zP/MzP/////M////yH5CiwheLrcLTBCd6Tv2qW16tdK4jhV
5qpraXIvM1JlNyAgOw==
@@ -1262,7 +1902,7 @@ test imgPhoto-18.1 {Reject corrupted GIF (binary string)} -setup {
} -cleanup {
catch {image delete gif1}
} -returnCodes error -result {error reading color map|not enough free memory for image buffer} -match regexp
-test imgPhoto-18.2 {Reject corrupted GIF (base 64 string)} -setup {
+test imgPhoto-20.2 {Reject corrupted GIF (base 64 string)} -setup {
set data {
R0lGODlhAAQABP8zM/8z/zP/MzP/////M////yH5CiwheLrcLTBCd6Tv2qW16tdK4jhV
5qpraXIvM1JlNyAgOw==
@@ -1272,14 +1912,14 @@ test imgPhoto-18.2 {Reject corrupted GIF (base 64 string)} -setup {
} -cleanup {
catch {image delete gif1}
} -returnCodes error -result {error reading color map|not enough free memory for image buffer} -match regexp
-test imgPhoto-18.3 {Reject corrupted GIF (file)} -setup {
+test imgPhoto-20.3 {Reject corrupted GIF (file)} -setup {
set fileName [file join [file dirname [info script]] corruptMangled.gif]
} -body {
image create photo gif1 -file $fileName
} -cleanup {
catch {image delete gif1}
} -returnCodes error -result {error reading color map|not enough free memory for image buffer} -match regexp
-test imgPhoto-18.4 {Reject truncated GIF (binary string)} -setup {
+test imgPhoto-20.4 {Reject truncated GIF (binary string)} -setup {
set data [binary decode base64 {
R0lGODlhEAAQAMIHAAAAADMz//8zM/8z/zP/MzP///8=
}]
@@ -1288,7 +1928,7 @@ test imgPhoto-18.4 {Reject truncated GIF (binary string)} -setup {
} -cleanup {
catch {image delete gif1}
} -returnCodes error -result {error reading color map}
-test imgPhoto-18.5 {Reject truncated GIF (base 64 string)} -setup {
+test imgPhoto-20.5 {Reject truncated GIF (base 64 string)} -setup {
set data {
R0lGODlhEAAQAMIHAAAAADMz//8zM/8z/zP/MzP///8=
}
@@ -1297,21 +1937,21 @@ test imgPhoto-18.5 {Reject truncated GIF (base 64 string)} -setup {
} -cleanup {
catch {image delete gif1}
} -returnCodes error -result {error reading color map}
-test imgPhoto-18.6 {Reject truncated GIF (file)} -setup {
+test imgPhoto-20.6 {Reject truncated GIF (file)} -setup {
set fileName [file join [file dirname [info script]] corruptTruncated.gif]
} -body {
image create photo gif1 -file $fileName
} -cleanup {
catch {image delete gif1}
} -returnCodes error -result {error reading color map}
-test imgPhoto-18.6.1 {Reject truncated GIF in Colormap - ticket 865af0148c - file} -setup {
+test imgPhoto-20.6.1 {Reject truncated GIF in Colormap - ticket 865af0148c - file} -setup {
set fileName [file join [file dirname [info script]] corruptTruncatedColormap.gif]
} -body {
image create photo gif1 -file $fileName
} -cleanup {
catch {image delete gif1}
} -returnCodes error -result {GIF file truncated}
-test imgPhoto-18.6.2 {Reject truncated GIF in Colormap - ticket 865af0148c - data} -setup {
+test imgPhoto-20.6.2 {Reject truncated GIF in Colormap - ticket 865af0148c - data} -setup {
set fileName [file join [file dirname [info script]] corruptTruncatedColormap.gif]
set h [open $fileName rb]
set d [read $h]
@@ -1321,7 +1961,7 @@ test imgPhoto-18.6.2 {Reject truncated GIF in Colormap - ticket 865af0148c - dat
} -cleanup {
catch {image delete gif1}
} -returnCodes error -result {GIF file truncated}
-test imgPhoto-18.7 {Reject corrupted GIF (> 4Gb) (binary string)} -constraints {
+test imgPhoto-20.7 {Reject corrupted GIF (> 4Gb) (binary string)} -constraints {
nonPortable
} -setup {
# About the non portability constraint of this test: see ticket [cc42cc18a5]
@@ -1337,7 +1977,7 @@ test imgPhoto-18.7 {Reject corrupted GIF (> 4Gb) (binary string)} -constraints {
} -cleanup {
catch {image delete gif1}
} -returnCodes error -result {error reading color map|not enough free memory for image buffer} -match regexp
-test imgPhoto-18.8 {Reject corrupted GIF (> 4Gb) (base 64 string)} -constraints {
+test imgPhoto-20.8 {Reject corrupted GIF (> 4Gb) (base 64 string)} -constraints {
nonPortable
} -setup {
# About the non portability constraint of this test: see ticket [cc42cc18a5]
@@ -1353,7 +1993,7 @@ test imgPhoto-18.8 {Reject corrupted GIF (> 4Gb) (base 64 string)} -constraints
} -cleanup {
catch {image delete gif1}
} -returnCodes error -result {error reading color map|not enough free memory for image buffer} -match regexp
-test imgPhoto-18.9 {Reject corrupted GIF (> 4Gb) (file)} -constraints {
+test imgPhoto-20.9 {Reject corrupted GIF (> 4Gb) (file)} -constraints {
nonPortable
} -setup {
# About the non portability constraint of this test: see ticket [cc42cc18a5]
@@ -1366,10 +2006,10 @@ test imgPhoto-18.9 {Reject corrupted GIF (> 4Gb) (file)} -constraints {
} -cleanup {
catch {image delete gif1}
} -returnCodes error -result {error reading color map|not enough free memory for image buffer} -match regexp
-test imgPhoto-18.10 {Valid GIF (binary string)} -setup {
+test imgPhoto-20.10 {Valid GIF (binary string)} -setup {
# Test the binary string reader with a valid GIF.
# This is not tested elsewhere.
- # Tests 18.11, 18.12, with matching data, are included for completeness.
+ # Tests 20.11, 20.12, with matching data, are included for completeness.
set data [binary decode base64 {
R0lGODlhEAAQAMIHAAAAADMz//8zM/8z/zP/MzP/////M////yH5BAEKAAcALAAA
AAAQABAAAAMheLrcLTBCd6QV79qlterXB0riOFXmmapraXIvM1IdZTcJADs=
@@ -1379,7 +2019,7 @@ test imgPhoto-18.10 {Valid GIF (binary string)} -setup {
} -cleanup {
catch {image delete gif1}
} -result gif1
-test imgPhoto-18.11 {Valid GIF (base 64 string)} -setup {
+test imgPhoto-20.11 {Valid GIF (base 64 string)} -setup {
set data {
R0lGODlhEAAQAMIHAAAAADMz//8zM/8z/zP/MzP/////M////yH5BAEKAAcALAAA
AAAQABAAAAMheLrcLTBCd6QV79qlterXB0riOFXmmapraXIvM1IdZTcJADs=
@@ -1389,7 +2029,7 @@ test imgPhoto-18.11 {Valid GIF (base 64 string)} -setup {
} -cleanup {
catch {image delete gif1}
} -result gif1
-test imgPhoto-18.12 {Valid GIF (file)} -setup {
+test imgPhoto-20.12 {Valid GIF (file)} -setup {
set fileName [file join [file dirname [info script]] red.gif]
} -body {
image create photo gif1 -file $fileName
@@ -1397,8 +2037,586 @@ test imgPhoto-18.12 {Valid GIF (file)} -setup {
catch {image delete gif1}
} -result gif1
+# imgPhoto-21.x : Tk_PhotoGetMetadata
+
+test imgPhoto-21.1 {option -metadata, get configure list} -setup {
+ image create photo photo1 -metadata {dpi 100}
+} -body {
+ photo1 configure -metadata
+} -cleanup {
+ catch {image delete photo1}
+} -result {-metadata {} {} {} {dpi 100}}
+
+test imgPhoto-21.2 {option -metadata, get value} -setup {
+ image create photo photo1 -metadata {dpi 100}
+} -body {
+ photo1 cget -metadata
+} -cleanup {
+ catch {image delete photo1}
+} -result {dpi 100}
+
+test imgPhoto-21.3 {option -metadata, get default value} -setup {
+ image create photo photo1
+} -body {
+ photo1 cget -metadata
+} -cleanup {
+ catch {image delete photo1}
+} -result {}
+
+test imgPhoto-21.4 {bug daa10097: only 3 metadata list items on configure} -setup {
+ image create photo photo1
+} -body {
+ set a {}
+ foreach line [photo1 configure] {
+ if {[lindex $line 0] eq {-metadata}} {
+ set a $line
+ }
+ }
+ set a
+} -cleanup {
+ catch {image delete photo1}
+} -result {-metadata {} {} {} {}}
+
+
+# imgPhoto-22.x : Tk_PhotoSetMetadata
+
+test imgPhoto-22.1 {option -metadata, set value} -setup {
+ image create photo photo1
+} -body {
+ photo1 configure -metadata {dpi 100}
+ photo1 cget -metadata
+} -cleanup {
+ catch {image delete photo1}
+} -result {dpi 100}
+
+test imgPhoto-22.2 {option -metadata, change value} -setup {
+ image create photo photo1 -metadata {dpi 200}
+} -body {
+ photo1 configure -metadata {dpi 100}
+ photo1 cget -metadata
+} -cleanup {
+ catch {image delete photo1}
+} -result {dpi 100}
+
+test imgPhoto-22.3 {option -metadata, clear value} -setup {
+ image create photo photo1 -metadata {dpi 200}
+} -body {
+ photo1 configure -metadata {}
+ photo1 cget -metadata
+} -cleanup {
+ catch {image delete photo1}
+} -result {}
+
+# 23.x GIF images with metadata
+
+# The following gif core data is used by the following data.
+# N.B. this is the same image as test imgPhoto-18.10
+
+# size 16x16, global color table size: 8
+set gifstart "GIF89a\x10\x00\x10\x00\xc2\x07\x00"
+# color table
+append gifstart "\x00\x00\x00\x33\x33\xff\xff\x33\x33\xff\x33\xff\x33\xff\x33\x33\xff\xff\xff\xff\x33\xff\xff\xff"
+# Graphic control extension: Transparent color index: 7 (not needed here)
+# append gifdata "\x21\xf9\x04\x01\x0a\x00\x07\x00"
+# Image descriptor: 16x16, no local color table
+set gifdata "\x2c\x00\x00\x00\x00\x10\x00\x10\x00\x00"
+# Image data
+append gifdata "\x03\x21\x78\xba\xdc\x2d\x30\x42\x77\xa4\x15\xef\xda\xa5\xb5\xea\xd7\x07\x4a\xe2\x38\x55\xe6\x99\xaa\x6b\x69\x72\x2f\x33\x52\x1d\x65\x37\x09\x00"
+set gifend "\x3b"
+
+test imgPhoto-23.1 {GIF comment before image data (-data)} -setup {
+ set data $::gifstart
+ # Append a comment extension block with data "ABCD"
+ append data "\x21\xfe\x04" "ABCD" "\x0"
+ # Trailer
+ append data $::gifdata $::gifend
+} -body {
+ image create photo gif1 -data $data
+ gif1 cget -metadata
+} -cleanup {
+ catch {image delete gif1}
+} -result {comment ABCD}
+
+test imgPhoto-23.2 {GIF file comment before image data (-file)} -setup {
+ set data $::gifstart
+ # Append a comment extension block with data "ABCD"
+ append data "\x21\xfe\x04" "ABCD" "\x0"
+ # Trailer
+ append data $::gifdata $::gifend
+ set path [file join [configure -tmpdir] test.gif]
+ set h [open $path "WRONLY BINARY CREAT"]
+ puts -nonewline $h $data
+ close $h
+} -body {
+ image create photo gif1 -file $path
+ gif1 cget -metadata
+} -cleanup {
+ catch {image delete gif1}
+ file delete $path
+} -result {comment ABCD}
+
+test imgPhoto-23.3 {GIF comment after image data (-data)} -setup {
+ set data $::gifstart
+ append data $::gifdata
+ # Append a comment extension block with data "ABCD"
+ append data "\x21\xfe\x04" "ABCD" "\x0"
+ # Trailer
+ append data $::gifend
+} -body {
+ image create photo gif1 -data $data
+ gif1 cget -metadata
+} -cleanup {
+ catch {image delete gif1}
+} -result {comment ABCD}
+
+test imgPhoto-23.4 {GIF comment after image data (-file)} -setup {
+ set data $::gifstart
+ append data $::gifdata
+ # Append a comment extension block with data "ABCD"
+ append data "\x21\xfe\x04" "ABCD" "\x0"
+ # Trailer
+ append data $::gifend
+ set path [file join [configure -tmpdir] test.gif]
+ set h [open $path "WRONLY BINARY CREAT"]
+ puts $h $data
+ close $h
+} -body {
+ image create photo gif1 -file $path
+ gif1 cget -metadata
+} -cleanup {
+ catch {image delete gif1}
+ file delete $path
+} -result {comment ABCD}
+
+test imgPhoto-23.5 {Two GIF comment blocks (-data)} -setup {
+ set data $::gifstart
+ # Append a comment extension block with data "1234"
+ append data "\x21\xfe\x04" "1234" "\x0"
+ append data $::gifdata
+ # Append a comment extension block with data "ABCD"
+ append data "\x21\xfe\x04" "ABCD" "\x0"
+ # Trailer
+ append data $::gifend
+} -body {
+ image create photo gif1 -data $data
+ gif1 cget -metadata
+} -cleanup {
+ catch {image delete gif1}
+} -result {comment ABCD}
+
+test imgPhoto-23.6 {Two GIF comment blocks (-file)} -setup {
+ set data $::gifstart
+ # Append a comment extension block with data "1234"
+ append data "\x21\xfe\x04" "1234" "\x0"
+ append data $::gifdata
+ # Append a comment extension block with data "ABCD"
+ append data "\x21\xfe\x04" "ABCD" "\x0"
+ # Trailer
+ append data $::gifend
+ set path [file join [configure -tmpdir] test.gif]
+ set h [open $path "WRONLY BINARY CREAT"]
+ puts $h $data
+ close $h
+} -body {
+ image create photo gif1 -file $path
+ gif1 cget -metadata
+} -cleanup {
+ catch {image delete gif1}
+ file delete $path
+} -result {comment ABCD}
+
+test imgPhoto-23.7 {create: test if shared metadata object is not preserved\
+ (-data)}\
+-setup {
+ set data $::gifstart
+ # Append a comment extension block with data "ABCD"
+ append data "\x21\xfe\x04" "ABCD" "\x0"
+ # Trailer
+ append data $::gifdata $::gifend
+} -body {
+ set metadataDict [dict create A 1]
+ set metadataDict2 $metadataDict
+ image create photo gif1 -data $data -metadata $metadataDict
+ list [dict get [gif1 cget -metadata]] $metadataDict $metadataDict2
+} -cleanup {
+ catch {image delete gif1}
+} -result {{A 1 comment ABCD} {A 1} {A 1}}
+
+test imgPhoto-23.8 {create: test if shared metadata object is not preserved\
+ (-file)}\
+-setup {
+ set data $::gifstart
+ # Append a comment extension block with data "ABCD"
+ append data "\x21\xfe\x04" "ABCD" "\x0"
+ # Trailer
+ append data $::gifdata $::gifend
+
+ set path [file join [configure -tmpdir] test.gif]
+ set h [open $path "WRONLY BINARY CREAT"]
+ puts $h $data
+ close $h
+} -body {
+ set metadataDict [dict create A 1]
+ set metadataDict2 $metadataDict
+ image create photo gif1 -file $path -metadata $metadataDict
+ list [dict get [gif1 cget -metadata]] $metadataDict $metadataDict2
+} -cleanup {
+ catch {image delete gif1}
+ file delete $path
+} -result {{A 1 comment ABCD} {A 1} {A 1}}
+
+test imgPhoto-23.9 {configure: test if shared metadata object is not\
+ preserved (empty image, -data)}\
+-setup {
+ set data $::gifstart
+ # Append a comment extension block with data "ABCD"
+ append data "\x21\xfe\x04" "ABCD" "\x0"
+ # Trailer
+ append data $::gifdata $::gifend
+} -body {
+ image create photo gif1
+ set metadataDict [dict create A 1]
+ set metadataDict2 $metadataDict
+ gif1 configure -data $data -format gif -metadata $metadataDict
+ list [dict get [gif1 cget -metadata]] $metadataDict $metadataDict2
+} -cleanup {
+ catch {image delete gif1}
+} -result {{A 1 comment ABCD} {A 1} {A 1}}
+
+test imgPhoto-23.10 {configure: test if shared metadata object is not preserved\
+ (empty image, -file)}\
+-setup {
+ set data $::gifstart
+ # Append a comment extension block with data "ABCD"
+ append data "\x21\xfe\x04" "ABCD" "\x0"
+ # Trailer
+ append data $::gifdata $::gifend
+
+ set path [file join [configure -tmpdir] test.gif]
+ set h [open $path "WRONLY BINARY CREAT"]
+ puts $h $data
+ close $h
+} -body {
+ image create photo gif1
+ set metadataDict [dict create A 1]
+ set metadataDict2 $metadataDict
+ gif1 configure -file $path -format gif -metadata $metadataDict
+ list [dict get [gif1 cget -metadata]] $metadataDict $metadataDict2
+} -cleanup {
+ catch {image delete gif1}
+ file delete $path
+} -result {{A 1 comment ABCD} {A 1} {A 1}}
+
+test imgPhoto-23.11 {configure: test if shared metadata object is not preserved\
+ (metadata replace, -data}\
+-setup {
+ set data $::gifstart
+ # Append a comment extension block with data "ABCD"
+ append data "\x21\xfe\x04" "ABCD" "\x0"
+ # Trailer
+ append data $::gifdata $::gifend
+} -body {
+ image create photo gif1 -data "$::gifstart$::gifdata$::gifend"
+ set metadataDict [dict create A 1]
+ set metadataDict2 $metadataDict
+ gif1 configure -data $data -format gif -metadata $metadataDict
+ list [dict get [gif1 cget -metadata]] $metadataDict $metadataDict2
+} -cleanup {
+ catch {image delete gif1}
+} -result {{A 1 comment ABCD} {A 1} {A 1}}
+
+test imgPhoto-23.12 {configure: test if shared metadata object is not preserved\
+ (metadata replace, -file}\
+-setup {
+ set data $::gifstart
+ # Append a comment extension block with data "ABCD"
+ append data "\x21\xfe\x04" "ABCD" "\x0"
+ # Trailer
+ append data $::gifdata $::gifend
+
+ set path [file join [configure -tmpdir] test.gif]
+ set h [open $path "WRONLY BINARY CREAT"]
+ puts $h $data
+ close $h
+} -body {
+ image create photo gif1 -data "$::gifstart$::gifdata$::gifend"
+ set metadataDict [dict create A 1]
+ set metadataDict2 $metadataDict
+ gif1 configure -file $path -format gif -metadata $metadataDict
+ list [dict get [gif1 cget -metadata]] $metadataDict $metadataDict2
+} -cleanup {
+ catch {image delete gif1}
+ file delete $path
+} -result {{A 1 comment ABCD} {A 1} {A 1}}
+
+test imgPhoto-23.13 {configure: test if shared metadata object is not preserved\
+ (-data)}\
+-setup {
+ set data $::gifstart$::gifdata$::gifend
+} -body {
+ image create photo gif1 -data $data
+ set metadataDict [dict create A 1]
+ set metadataDict2 $metadataDict
+ set data $::gifstart
+ # Append a comment extension block with data "ABCD"
+ append data "\x21\xfe\x04" "ABCD" "\x0"
+ # Trailer
+ append data $::gifdata $::gifend
+ gif1 configure -data $data -format gif -metadata $metadataDict
+ list [dict get [gif1 cget -metadata]] $metadataDict $metadataDict2
+} -cleanup {
+ catch {image delete gif1}
+} -result {{A 1 comment ABCD} {A 1} {A 1}}
+
+test imgPhoto-23.14 {configure: test if shared metadata object is not preserved\
+ (-file)}\
+-setup {
+ set data $::gifstart
+ # Append a comment extension block with data "ABCD"
+ append data "\x21\xfe\x04" "ABCD" "\x0"
+ # Trailer
+ append data $::gifdata $::gifend
+
+ set path [file join [configure -tmpdir] test.gif]
+ set h [open $path "WRONLY BINARY CREAT"]
+ puts $h $data
+ close $h
+} -body {
+ image create photo gif1 -data "$::gifstart$::gifdata$::gifend"
+ set metadataDict [dict create A 1]
+ set metadataDict2 $metadataDict
+ gif1 configure -file $path -format gif -metadata $metadataDict
+ list [dict get [gif1 cget -metadata]] $metadataDict $metadataDict2
+} -cleanup {
+ catch {image delete gif1}
+ file delete $path
+} -result {{A 1 comment ABCD} {A 1} {A 1}}
+
+test imgPhoto-23.15 {output data with comment (from -metadata argument)}\
+-setup {
+ set data $::gifstart$::gifdata$::gifend
+} -body {
+ image create photo gif1 -data $data
+ set gifData [gif1 data -format gif -metadata [dict create comment ABCD]]
+} -cleanup {
+ catch {image delete gif1}
+} -match glob -result {*ABCD*}
+
+test imgPhoto-23.16 {output data with comment (from -metadata property)}\
+-setup {
+ set data $::gifstart$::gifdata$::gifend
+} -body {
+ image create photo gif1 -data $data
+ gif1 configure -metadata [dict create comment ABCD]
+ set gifData [gif1 data -format gif]
+} -cleanup {
+ catch {image delete gif1}
+} -match glob -result {*ABCD*}
+
+test imgPhoto-23.17 {output file with comment (from -metadata property)}\
+-setup {
+ set data $::gifstart$::gifdata$::gifend
+ set path [file join [configure -tmpdir] test.gif]
+} -body {
+ image create photo gif1 -data $data
+ gif1 configure -metadata [dict create comment ABCD]
+ gif1 write $path -format gif
+ image delete gif1
+ image create photo gif1 -file $path
+ dict get [gif1 cget -metadata] comment
+} -cleanup {
+ catch {image delete gif1}
+ file delete $path
+} -result {ABCD}
+
+test imgPhoto-23.18 {configure: empty metadata parameter overwrites image metadata} -setup {
+ image create photo gif1 -data $::gifstart$::gifdata$::gifend\
+ -metadata {foo bar}
+ set data $::gifstart
+ # Append a comment extension block with data "ABCD"
+ append data "\x21\xfe\x04" "ABCD" "\x0"
+ # Trailer
+ append data $::gifdata $::gifend
+} -body {
+ gif1 configure -data $data -metadata {}
+ gif1 cget -metadata
+} -cleanup {
+ catch {image delete gif1}
+} -result {comment ABCD}
+
+test imgPhoto-23.19 {write: empty metadata parameter overwrites image metadata} -setup {
+ image create photo gif1 -data $::gifstart$::gifdata$::gifend\
+ -metadata {comment bar}
+ set path [file join [configure -tmpdir] test.gif]
+} -body {
+ gif1 write $path -format gif -metadata {}
+ image delete gif1
+ image create photo gif1 -file $path
+ dict size [gif1 cget -metadata]
+} -cleanup {
+ catch {image delete gif1}
+ file delete $path
+} -result {0}
+
+test imgPhoto-23.20 {data: empty metadata parameter overwrites image metadata} -setup {
+ image create photo gif1 -data $::gifstart$::gifdata$::gifend\
+ -metadata {comment bar}
+} -body {
+ set data [gif1 data -format gif -metadata {}]
+ image delete gif1
+ image create photo gif1 -data $data
+ dict size [gif1 cget -metadata]
+} -cleanup {
+ catch {image delete gif1}
+ file delete $path
+} -result {0}
+
+test imgPhoto-23.21 {GIF delay time metadata} -setup {
+ set data $::gifstart
+ # Graphic control extension: 10 1/100s delay time
+ append data "\x21\xf9\x04\x00\x0a\x00\x00\x00"
+ # Trailer
+ append data $::gifdata $::gifend
+} -body {
+ image create photo gif1 -data $data
+ gif1 cget -metadata
+} -cleanup {
+ catch {image delete gif1}
+} -result {{delay time} 10}
+
+test imgPhoto-23.22 {GIF disposal method "do not dispose" metadata} -setup {
+ set data $::gifstart
+ # Graphic control extension: disposdal method:
+ append data "\x21\xf9\x04\x04\x00\x00\x00\x00"
+ # Trailer
+ append data $::gifdata $::gifend
+} -body {
+ image create photo gif1 -data $data
+ gif1 cget -metadata
+} -cleanup {
+ catch {image delete gif1}
+} -result {{disposal method} {do not dispose}}
+
+test imgPhoto-23.23 {GIF disposal method "restore to background color" metadata} -setup {
+ set data $::gifstart
+ # Graphic control extension: disposdal method:
+ append data "\x21\xf9\x04\x08\x00\x00\x00\x00"
+ # Trailer
+ append data $::gifdata $::gifend
+} -body {
+ image create photo gif1 -data $data
+ gif1 cget -metadata
+} -cleanup {
+ catch {image delete gif1}
+} -result {{disposal method} {restore to background color}}
+
+test imgPhoto-23.24 {GIF disposal method "restore to previous" metadata} -setup {
+ set data $::gifstart
+ # Graphic control extension: disposdal method:
+ append data "\x21\xf9\x04\x0C\x00\x00\x00\x00"
+ # Trailer
+ append data $::gifdata $::gifend
+} -body {
+ image create photo gif1 -data $data
+ gif1 cget -metadata
+} -cleanup {
+ catch {image delete gif1}
+} -result {{disposal method} {restore to previous}}
+
+test imgPhoto-23.25 {GIF user input flag metadata} -setup {
+ set data $::gifstart
+ # Graphic control extension: disposdal method:
+ append data "\x21\xf9\x04\x02\x00\x00\x00\x00"
+ # Trailer
+ append data $::gifdata $::gifend
+} -body {
+ image create photo gif1 -data $data
+ gif1 cget -metadata
+} -cleanup {
+ catch {image delete gif1}
+} -result {{user interaction} 1}
+
+test imgPhoto-23.26 {GIF update region metadata} -setup {
+ # size 32x32, global color table size: 8
+ set data "GIF89a\x20\x00\x20\x00\xc2\x07\x00"
+ # color table
+ append data "\x00\x00\x00\x33\x33\xff\xff\x33\x33\xff\x33\xff\x33\xff\x33\x33\xff\xff\xff\xff\x33\xff\xff\xff"
+ # Trailer
+ # As this is 16x16, we will get an update region setting
+ append data $::gifdata $::gifend
+} -body {
+ image create photo gif1 -data $data
+ gif1 cget -metadata
+} -cleanup {
+ catch {image delete gif1}
+} -result {{update region} {0 0 16 16}}
+
+test imgPhoto-23.27 {GIF multiple options metadata} -setup {
+ # size 32x32, global color table size: 8
+ set data "GIF89a\x20\x00\x20\x00\xc2\x07\x00"
+ # color table
+ append data "\x00\x00\x00\x33\x33\xff\xff\x33\x33\xff\x33\xff\x33\xff\x33\x33\xff\xff\xff\xff\x33\xff\xff\xff"
+ # Graphic control extension: do not dispose, user interaction, transparent color, delay time 10
+ append data "\x21\xf9\x04\x07\x0a\x00\x01\x00"
+ # Image data and trailer
+ # As this is 16x16, we will get an update region setting
+ append data $::gifdata $::gifend
+} -body {
+ image create photo gif1 -data $data
+ gif1 cget -metadata
+} -cleanup {
+ catch {image delete gif1}
+} -result {{update region} {0 0 16 16} {delay time} 10 {disposal method} {do not dispose} {user interaction} 1}
+
+test imgPhoto-23.28 {GIF multiple options metadata in -index 0} -setup {
+ # size 32x32, global color table size: 8
+ set data "GIF89a\x20\x00\x20\x00\xc2\x07\x00"
+ # color table
+ append data "\x00\x00\x00\x33\x33\xff\xff\x33\x33\xff\x33\xff\x33\xff\x33\x33\xff\xff\xff\xff\x33\xff\xff\xff"
+ # Graphic control extension: do not dispose, user interaction, transparent color, delay time 4096
+ append data "\x21\xf9\x04\x07\x00\x10\x01\x00"
+ # Image data
+ # As this is 16x16, we will get an update region setting
+ append data $::gifdata
+ # Graphic control extension: restore to background, delay time 1
+ append data "\x21\xf9\x04\x08\x01\x00\x02\x00"
+ # Image data and trailer
+ # As this is 16x16, we will get an update region setting
+ append data $::gifdata $::gifend
+} -body {
+ image create photo gif1 -data $data -format "gif -index 0"
+ gif1 cget -metadata
+} -cleanup {
+ catch {image delete gif1}
+} -result {{update region} {0 0 16 16} {delay time} 4096 {disposal method} {do not dispose} {user interaction} 1}
+
+test imgPhoto-23.29 {GIF multiple options metadata in -index 1} -setup {
+ # size 32x32, global color table size: 8
+ set data "GIF89a\x20\x00\x20\x00\xc2\x07\x00"
+ # color table
+ append data "\x00\x00\x00\x33\x33\xff\xff\x33\x33\xff\x33\xff\x33\xff\x33\x33\xff\xff\xff\xff\x33\xff\xff\xff"
+ # Graphic control extension: restore to background, delay time 1
+ append data "\x21\xf9\x04\x08\x01\x00\x02\x00"
+ # Image data
+ # As this is 16x16, we will get an update region setting
+ append data $::gifdata
+ # Graphic control extension: do not dispose, user interaction, transparent color, delay time 4096
+ append data "\x21\xf9\x04\x07\x00\x10\x01\x00"
+ # Image data and trailer
+ # As this is 16x16, we will get an update region setting
+ append data $::gifdata $::gifend
+} -body {
+ image create photo gif1 -data $data -format "gif -index 1"
+ gif1 cget -metadata
+} -cleanup {
+ catch {image delete gif1}
+} -result {{update region} {0 0 16 16} {delay time} 4096 {disposal method} {do not dispose} {user interaction} 1}
+
+unset -nocomplain gifstart gifdata gifend
+
+
set earthPhotoFile [file join [file dirname [info script]] earth.gif]
-test imgPhoto-19.1 {Read GIF file with -from option - Bug [1576528]} -body {
+test imgPhoto-24.1 {Read GIF file with -from option - Bug [1576528]} -body {
set earthPhotoFile [file join [file dirname [info script]] earth.gif]
image create photo gif1
gif1 read $earthPhotoFile -from 152 62 185 97
@@ -1406,7 +2624,7 @@ test imgPhoto-19.1 {Read GIF file with -from option - Bug [1576528]} -body {
} -cleanup {
catch {image delete gif1}
} -result {{#d8c8b8} 33 35}
-test imgPhoto-19.2 {Read GIF file, copy with -from option} -body {
+test imgPhoto-24.2 {Read GIF file, copy with -from option} -body {
set earthPhotoFile [file join [file dirname [info script]] earth.gif]
image create photo gif1 -file $earthPhotoFile
image create photo gif2
@@ -1415,14 +2633,14 @@ test imgPhoto-19.2 {Read GIF file, copy with -from option} -body {
} -cleanup {
catch {image delete gif1 ; image delete gif2}
} -result {{#d8c8b8} 33 35}
-test imgPhoto-19.3 {Read GIF file with -to option} -body {
+test imgPhoto-24.3 {Read GIF file with -to option} -body {
image create photo gif1
gif1 read $earthPhotoFile -to 100 200
list [lindex [lindex [gif1 data] 262] 252] [image width gif1] [image height gif1]
} -cleanup {
catch {image delete gif1}
} -result {{#d8c8b8} 420 400}
-test imgPhoto-19.4 {Read GIF file with -from and -to options} -body {
+test imgPhoto-24.4 {Read GIF file with -from and -to options} -body {
set earthPhotoFile [file join [file dirname [info script]] earth.gif]
image create photo gif1
gif1 read $earthPhotoFile -from 152 62 185 97 -to 100 200
@@ -1430,7 +2648,7 @@ test imgPhoto-19.4 {Read GIF file with -from and -to options} -body {
} -cleanup {
catch {image delete gif1}
} -result {{#d8c8b8} 133 235}
-test imgPhoto-19.5 {Read GIF file with -from, -to and -shrink options} -body {
+test imgPhoto-24.5 {Read GIF file with -from, -to and -shrink options} -body {
set earthPhotoFile [file join [file dirname [info script]] earth.gif]
image create photo gif1 -file $teapotPhotoFile
gif1 read $earthPhotoFile -from 152 62 185 97 -to 80 120 -shrink
@@ -1438,7 +2656,7 @@ test imgPhoto-19.5 {Read GIF file with -from, -to and -shrink options} -body {
} -cleanup {
catch {image delete gif1}
} -result {{#d8c8b8} 113 155}
-test imgPhoto-19.6 {Read GIF file with -from option, read large region from small file} -body {
+test imgPhoto-24.6 {Read GIF file with -from option, read large region from small file} -body {
set earthPhotoFile [file join [file dirname [info script]] earth.gif]
image create photo gif1
catch {gif1 read $earthPhotoFile -from 152 62 2000 1000} msg
@@ -1449,14 +2667,14 @@ test imgPhoto-19.6 {Read GIF file with -from option, read large region from smal
unset earthPhotoFile
set ousterPhotoFile [file join [file dirname [info script]] ouster.png]
-test imgPhoto-20.1 {Read PNG file with -from option - Bug [1576528]} -body {
+test imgPhoto-25.1 {Read PNG file with -from option - Bug [1576528]} -body {
image create photo png1
png1 read $ousterPhotoFile -from 102 62 135 97
list [lindex [lindex [png1 data] 0] 0] [image width png1] [image height png1]
} -cleanup {
catch {image delete png1}
} -result {{#c97962} 33 35}
-test imgPhoto-20.2 {Read PNG file, copy with -from option} -body {
+test imgPhoto-25.2 {Read PNG file, copy with -from option} -body {
image create photo png1 -file $ousterPhotoFile
image create photo png2
png2 copy png1 -from 102 62 135 97
@@ -1464,28 +2682,28 @@ test imgPhoto-20.2 {Read PNG file, copy with -from option} -body {
} -cleanup {
catch {image delete png1 ; image delete png2}
} -result {{#c97962} 33 35}
-test imgPhoto-20.3 {Read PNG file with -to option} -body {
+test imgPhoto-25.3 {Read PNG file with -to option} -body {
image create photo png1
png1 read $ousterPhotoFile -to 100 200
list [lindex [lindex [png1 data] 262] 202] [image width png1] [image height png1]
} -cleanup {
catch {image delete png1}
} -result {{#c97962} 242 381}
-test imgPhoto-20.4 {Read PNG file with -from and -to options} -body {
+test imgPhoto-25.4 {Read PNG file with -from and -to options} -body {
image create photo png1
png1 read $ousterPhotoFile -from 102 62 135 97 -to 100 200
list [lindex [lindex [png1 data] 200] 100] [image width png1] [image height png1]
} -cleanup {
catch {image delete png1}
} -result {{#c97962} 133 235}
-test imgPhoto-20.5 {Read PNG file with -from, -to and -shrink options} -body {
+test imgPhoto-25.5 {Read PNG file with -from, -to and -shrink options} -body {
image create photo png1 -file $teapotPhotoFile
png1 read $ousterPhotoFile -from 102 62 135 97 -to 80 120 -shrink
list [lindex [lindex [png1 data] 120] 80] [image width png1] [image height png1]
} -cleanup {
catch {image delete png1}
} -result {{#c97962} 113 155}
-test imgPhoto-20.6 {Read PNG file with -from option, read large region from small file} -body {
+test imgPhoto-25.6 {Read PNG file with -from option, read large region from small file} -body {
image create photo png1
catch {png1 read $ousterPhotoFile -from 102 62 2000 1000} msg
list $msg [image width png1] [image height png1]
generated by cgit v0.12 at 2024-11-12 23:00:59 (GMT)