summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorfvogel <fvogelnew1@free.fr>2024-06-11 03:34:15 (GMT)
committerfvogel <fvogelnew1@free.fr>2024-06-11 03:34:15 (GMT)
commitc9fe293db7a52a34954db92d2bdc5454d4de3897 (patch)
tree39c9342e0c9b887fedff449c1ac24969e0352c94
parent530397e0787965a065721a983cfea4da07446f1b (diff)
parent15dc2cfa976b10c2dcd29e446a331a7d7f04b790 (diff)
downloadtk-c9fe293db7a52a34954db92d2bdc5454d4de3897.zip
tk-c9fe293db7a52a34954db92d2bdc5454d4de3897.tar.gz
tk-c9fe293db7a52a34954db92d2bdc5454d4de3897.tar.bz2
Fix [1576528fff]: image read file with -from option. (and resolve merge conflicts)
-rw-r--r--generic/tkImgGIF.c15
-rw-r--r--generic/tkImgPNG.c74
-rw-r--r--tests/imgListFormat.test32
-rw-r--r--tests/imgPhoto.test248
-rw-r--r--tests/menu.test71
-rw-r--r--tests/ouster.pngbin0 -> 54257 bytes
6 files changed, 214 insertions, 226 deletions
diff --git a/generic/tkImgGIF.c b/generic/tkImgGIF.c
index 9b70344..6368972 100644
--- a/generic/tkImgGIF.c
+++ b/generic/tkImgGIF.c
@@ -704,6 +704,7 @@ FileReadGIF(
}
if ((width > 0) && (height > 0)) {
+ unsigned char* pixelPtr;
Tk_PhotoImageBlock block;
int transparent = -1;
if (gifGraphicControlExtensionBlock.blockPresent) {
@@ -729,23 +730,25 @@ FileReadGIF(
goto error;
}
nBytes = block.pitch * imageHeight;
- block.pixelPtr = (unsigned char *)ckalloc(nBytes);
- if (block.pixelPtr) {
- memset(block.pixelPtr, 0, nBytes);
+ pixelPtr = (unsigned char*)ckalloc(nBytes);
+ if (pixelPtr) {
+ memset(pixelPtr, 0, nBytes);
}
+ block.pixelPtr = pixelPtr;
if (ReadImage(gifConfPtr, interp, block.pixelPtr, chan, imageWidth,
imageHeight, colorMap, srcX, srcY, BitSet(buf[8], INTERLACE),
transparent) != TCL_OK) {
- ckfree(block.pixelPtr);
+ ckfree(pixelPtr);
goto error;
}
+ block.pixelPtr += srcX * block.pixelSize + srcY * block.pitch;
if (Tk_PhotoPutBlock(interp, imageHandle, &block, destX, destY,
width, height, TK_PHOTO_COMPOSITE_SET) != TCL_OK) {
- ckfree(block.pixelPtr);
+ ckfree(pixelPtr);
goto error;
}
- ckfree(block.pixelPtr);
+ ckfree(pixelPtr);
}
/*
diff --git a/generic/tkImgPNG.c b/generic/tkImgPNG.c
index 5eb85a7..2879ae2 100644
--- a/generic/tkImgPNG.c
+++ b/generic/tkImgPNG.c
@@ -205,7 +205,8 @@ static void CleanupPNGImage(PNGImage *pngPtr);
static int DecodeLine(Tcl_Interp *interp, PNGImage *pngPtr);
static int DecodePNG(Tcl_Interp *interp, PNGImage *pngPtr,
Tcl_Obj *fmtObj, Tk_PhotoHandle imageHandle,
- int destX, int destY);
+ int destX, int destY, int width, int height,
+ int srcX, int srcY);
static int EncodePNG(Tcl_Interp *interp,
Tk_PhotoImageBlock *blockPtr, PNGImage *pngPtr,
Tcl_Obj *metadataInObj);
@@ -2476,14 +2477,19 @@ ParseFormat(
static int
DecodePNG(
- Tcl_Interp *interp,
- PNGImage *pngPtr,
- Tcl_Obj *fmtObj,
- Tk_PhotoHandle imageHandle,
- int destX,
- int destY)
+ Tcl_Interp *interp, /* Interpreter to use for reporting errors. */
+ PNGImage *pngPtr, /* PNG image information record. */
+ Tcl_Obj *fmtObj, /* User-specified format object, or NULL. */
+ Tk_PhotoHandle imageHandle, /* The photo image to write into. */
+ int destX, int destY, /* Coordinates of top-left pixel in photo
+ * image to be written to. */
+ int width, int height, /* Dimensions of block of photo image to be
+ * written to. */
+ int srcX, int srcY) /* Coordinates of top-left pixel to be used in
+ * image being read. */
{
unsigned long chunkType;
+ int result;
Tcl_Size chunkSz;
unsigned long crc;
@@ -2631,8 +2637,8 @@ DecodePNG(
* to negative here: Tk will not shrink the image.
*/
- if (Tk_PhotoExpand(interp, imageHandle, destX + pngPtr->block.width,
- destY + pngPtr->block.height) == TCL_ERROR) {
+ if (Tk_PhotoExpand(interp, imageHandle, destX + width,
+ destY + height) == TCL_ERROR) {
return TCL_ERROR;
}
@@ -2786,13 +2792,12 @@ DecodePNG(
* Copy the decoded image block into the Tk photo image.
*/
- if (Tk_PhotoPutBlock(interp, imageHandle, &pngPtr->block, destX, destY,
- pngPtr->block.width, pngPtr->block.height,
- TK_PHOTO_COMPOSITE_SET) == TCL_ERROR) {
- return TCL_ERROR;
- }
+ pngPtr->block.pixelPtr += srcX * pngPtr->block.pixelSize + srcY * pngPtr->block.pitch;
+ result = Tk_PhotoPutBlock(interp, imageHandle, &pngPtr->block, destX, destY,
+ width, height, TK_PHOTO_COMPOSITE_SET);
+ pngPtr->block.pixelPtr -= srcX * pngPtr->block.pixelSize + srcY * pngPtr->block.pitch;
- return TCL_OK;
+ return result;
}
/*
@@ -2862,21 +2867,19 @@ FileMatchPNG(
static int
FileReadPNG(
- Tcl_Interp *interp, /* Interpreter to use for reporting errors. */
+ Tcl_Interp* interp, /* Interpreter to use for reporting errors. */
Tcl_Channel chan, /* The image file, open for reading. */
- TCL_UNUSED(const char *), /* The name of the image file. */
+ TCL_UNUSED(const char*), /* The name of the image file. */
Tcl_Obj *fmtObj, /* User-specified format object, or NULL. */
- TCL_UNUSED(Tcl_Obj *), /* metadata input, may be NULL */
+ TCL_UNUSED(Tcl_Obj*), /* metadata input, may be NULL */
Tk_PhotoHandle imageHandle, /* The photo image to write into. */
int destX, int destY, /* Coordinates of top-left pixel in photo
* image to be written to. */
- TCL_UNUSED(int), /* Dimensions of block of photo image to be
+ int width, int height, /* Dimensions of block of photo image to be
* written to. */
- TCL_UNUSED(int),
- TCL_UNUSED(int), /* Coordinates of top-left pixel to be used in
+ int srcX, int srcY, /* Coordinates of top-left pixel to be used in
* image being read. */
- TCL_UNUSED(int),
- Tcl_Obj *metadataOutObj) /* metadata return dict, may be NULL */
+ Tcl_Obj* metadataOutObj) /* metadata return dict, may be NULL */
{
PNGImage png;
int result = TCL_ERROR;
@@ -2884,7 +2887,7 @@ FileReadPNG(
result = InitPNGImage(interp, &png, chan, NULL, TCL_ZLIB_STREAM_INFLATE);
if (TCL_OK == result) {
- result = DecodePNG(interp, &png, fmtObj, imageHandle, destX, destY);
+ result = DecodePNG(interp, &png, fmtObj, imageHandle, destX, destY, width, height, srcX, srcY);
}
if (TCL_OK == result && metadataOutObj != NULL && png.DPI != -1) {
@@ -2968,16 +2971,17 @@ StringMatchPNG(
static int
StringReadPNG(
- Tcl_Interp *interp, /* interpreter for reporting errors in */
- Tcl_Obj *pObjData, /* object containing the image */
- Tcl_Obj *fmtObj, /* format object, or NULL */
- TCL_UNUSED(Tcl_Obj *), /* metadata input, may be NULL */
- Tk_PhotoHandle imageHandle, /* the image to write this data into */
- int destX, int destY, /* The rectangular region of the */
- TCL_UNUSED(int), /* image to copy */
- TCL_UNUSED(int),
- TCL_UNUSED(int),
- TCL_UNUSED(int),
+ Tcl_Interp* interp, /* Interpreter to use for reporting errors. */
+ Tcl_Obj *pObjData,
+ Tcl_Obj *fmtObj, /* User-specified format object, or NULL. */
+ TCL_UNUSED(Tcl_Obj*), /* metadata input, may be NULL */
+ Tk_PhotoHandle imageHandle, /* The photo image to write into. */
+ int destX, int destY, /* Coordinates of top-left pixel in photo
+ * image to be written to. */
+ int width, int height, /* Dimensions of block of photo image to be
+ * written to. */
+ int srcX, int srcY, /* Coordinates of top-left pixel to be used in
+ * image being read. */
Tcl_Obj *metadataOutObj) /* metadata return dict, may be NULL */
{
PNGImage png;
@@ -2987,7 +2991,7 @@ StringReadPNG(
TCL_ZLIB_STREAM_INFLATE);
if (TCL_OK == result) {
- result = DecodePNG(interp, &png, fmtObj, imageHandle, destX, destY);
+ result = DecodePNG(interp, &png, fmtObj, imageHandle, destX, destY, width, height, srcX, srcY);
}
if (TCL_OK == result && metadataOutObj != NULL && png.DPI != -1) {
diff --git a/tests/imgListFormat.test b/tests/imgListFormat.test
index 4877645..3c6da21 100644
--- a/tests/imgListFormat.test
+++ b/tests/imgListFormat.test
@@ -14,12 +14,8 @@ tcltest::loadTestedCommands
imageInit
-# find the teapot.ppm file for use in these tests
set teapotPhotoFile [file join [file dirname [info script]] teapot.ppm]
-testConstraint hasTeapotPhoto [file exists $teapotPhotoFile]
-# let's see if we have the semi-transparent one as well
set transpTeapotPhotoFile [file join [file dirname [info script]] teapotTransparent.png]
-testConstraint hasTranspTeapotPhoto [file exists $transpTeapotPhotoFile]
# ---------------------------------------------------------------------
@@ -175,9 +171,7 @@ test imgListFormat-4.3 {StringReadDef: erroneous non-option argument} -setup {
} -body {
photo1 put orange -format {default bogus}
} -returnCodes error -result {bad format option "bogus": no options allowed}
-test imgListFormat-4.4 {StringReadDef: normal use case} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgListFormat-4.4 {StringReadDef: normal use case} -setup {
image create photo photo1 -file $teapotPhotoFile
image create photo photo2
} -body {
@@ -188,9 +182,7 @@ test imgListFormat-4.4 {StringReadDef: normal use case} -constraints {
imageCleanup
unset imgData
} -result 1
-test imgListFormat-4.5 {StringReadDef: correct compositing rule} -constraints {
- hasTranspTeapotPhoto
-} -setup {
+test imgListFormat-4.5 {StringReadDef: correct compositing rule} -setup {
image create photo photo1 -file $transpTeapotPhotoFile
image create photo photo2
} -body {
@@ -241,9 +233,7 @@ test imgListFormat-5.5 {StirngWriteDef: size of data} -setup {
unset imgData
imageCleanup
} -result {35 64}
-test imgListFormat-5.6 {StringWriteDef: test some pixels #1} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgListFormat-5.6 {StringWriteDef: test some pixels #1} -setup {
set result {}
image create photo photo1 -file $teapotPhotoFile
} -body {
@@ -260,9 +250,7 @@ test imgListFormat-5.6 {StringWriteDef: test some pixels #1} -constraints {
unset imgData
imageCleanup
} -result {{#135cc0} #135cc0 #a06d52 #e1c8ba #135cc0}
-test imgListFormat-5.7 {StringWriteDef: test some pixels #2} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgListFormat-5.7 {StringWriteDef: test some pixels #2} -setup {
set result {}
image create photo photo1 -file $teapotPhotoFile
} -body {
@@ -279,9 +267,7 @@ test imgListFormat-5.7 {StringWriteDef: test some pixels #2} -constraints {
unset imgData
imageCleanup
} -result {{#135cc0ff} #135cc0ff #a06d52ff #e1c8baff #135cc0ff}
-test imgListFormat-5.8 {StringWriteDef: test some pixels #3} -constraints {
- hasTranspTeapotPhoto
-} -setup {
+test imgListFormat-5.8 {StringWriteDef: test some pixels #3} -setup {
image create photo photo1 -file $transpTeapotPhotoFile
} -body {
set imgData [photo1 data -format {default -colorformat rgb}]
@@ -295,9 +281,7 @@ test imgListFormat-5.8 {StringWriteDef: test some pixels #3} -constraints {
unset imgData
imageCleanup
} -result {{#004eb9} #a14100 #ffca9f}
-test imgListFormat-5.9 {StringWriteDef: test some pixels #4} -constraints {
- hasTranspTeapotPhoto
-} -setup {
+test imgListFormat-5.9 {StringWriteDef: test some pixels #4} -setup {
image create photo photo1 -file $transpTeapotPhotoFile
} -body {
set imgData [photo1 data -format {default -colorformat rgba}]
@@ -310,9 +294,7 @@ test imgListFormat-5.9 {StringWriteDef: test some pixels #4} -constraints {
unset imgData
imageCleanup
} -result {{#004eb9e1} #a14100aa #ffca9faf}
-test imgListFormat-5.10 {StringWriteDef: test some pixels #5} -constraints {
- hasTranspTeapotPhoto
-} -setup {
+test imgListFormat-5.10 {StringWriteDef: test some pixels #5} -setup {
image create photo photo1 -file $transpTeapotPhotoFile
} -body {
set imgData [photo1 data -format {default -colorformat list}]
diff --git a/tests/imgPhoto.test b/tests/imgPhoto.test
index 58c8653..29e6b53 100644
--- a/tests/imgPhoto.test
+++ b/tests/imgPhoto.test
@@ -119,12 +119,9 @@ set README [makeFile {
README -- Tk test suite design document.
} README-imgPhoto]
-# find the teapot.ppm file for use in these tests
set teapotPhotoFile [file join [file dirname [info script]] teapot.ppm]
-testConstraint hasTeapotPhoto [file exists $teapotPhotoFile]
-# let's see if we have the semi-transparent one as well
set transpTeapotPhotoFile [file join [file dirname [info script]] teapotTransparent.png]
-testConstraint hasTranspTeapotPhoto [file exists $transpTeapotPhotoFile]
+
testConstraint needsTcl867 [package vsatisfies [package provide Tcl] 8.6.7-]
@@ -139,16 +136,16 @@ test imgPhoto-1.2 {options for photo images} -body {
list [catch {image create photo photo1 -file no.such.file} err] \
[string tolower $err]
} -result {1 {couldn't open "no.such.file": no such file or directory}}
-test imgPhoto-1.3 {options for photo images} -constraints hasTeapotPhoto -body {
+test imgPhoto-1.3 {options for photo images} -body {
image create photo photo1 -file $teapotPhotoFile -format no.such.format
} -returnCodes error -result {image file format "no.such.format" is not supported}
-test imgPhoto-1.4 {options for photo images} -constraints hasTeapotPhoto -body {
+test imgPhoto-1.4 {options for photo images} -body {
image create photo photo1 -file $teapotPhotoFile
list [image width photo1] [image height photo1]
} -cleanup {
image delete photo1
} -result {256 256}
-test imgPhoto-1.5 {options for photo images} -constraints hasTeapotPhoto -body {
+test imgPhoto-1.5 {options for photo images} -body {
image create photo photo1 -file $teapotPhotoFile \
-format ppm -width 79 -height 83
list [image width photo1] [image height photo1] [photo1 cget -file] [photo1 cget -format]
@@ -219,26 +216,20 @@ test imgPhoto-2.2 {ImgPhotoCreate procedure} -setup {
# set msg
# } {couldn't open "bogus.img": no such file or directory}
-test imgPhoto-3.1 {ImgPhotoConfigureModel procedure} -constraints {
- hasTeapotPhoto
-} -body {
+test imgPhoto-3.1 {ImgPhotoConfigureModel procedure} -body {
image create photo photo1 -file $teapotPhotoFile
photo1 configure -file $teapotPhotoFile
} -cleanup {
image delete photo1
} -result {}
-test imgPhoto-3.2 {ImgPhotoConfigureModel procedure} -constraints {
- hasTeapotPhoto
-} -body {
+test imgPhoto-3.2 {ImgPhotoConfigureModel procedure} -body {
image create photo photo1 -file $teapotPhotoFile
list [catch {photo1 configure -file bogus} err] [string tolower $err] \
[image width photo1] [image height photo1]
} -cleanup {
image delete photo1
} -result {1 {couldn't open "bogus": no such file or directory} 256 256}
-test imgPhoto-3.3 {ImgPhotoConfigureModel procedure} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgPhoto-3.3 {ImgPhotoConfigureModel procedure} -setup {
destroy .c
pack [canvas .c]
update
@@ -254,9 +245,7 @@ test imgPhoto-3.3 {ImgPhotoConfigureModel procedure} -constraints {
destroy .c
image delete photo1
} -result {256 256 {10 10 266 266} {300 10 556 266}}
-test imgPhoto-3.4 {ImgPhotoConfigureModel: -data <ppm>} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgPhoto-3.4 {ImgPhotoConfigureModel: -data <ppm>} -setup {
image create photo photo1 -file $teapotPhotoFile
image create photo photo2
} -body {
@@ -267,7 +256,7 @@ test imgPhoto-3.4 {ImgPhotoConfigureModel: -data <ppm>} -constraints {
} -result {20 20}
# This testcase fails with Tcl < 8.6.7, due to [25842c]
test imgPhoto-3.5 {ImgPhotoConfigureModel: -data <png>} -constraints {
- hasTeapotPhoto needsTcl867
+ needsTcl867
} -setup {
image create photo photo1 -file $teapotPhotoFile
image create photo photo2
@@ -277,9 +266,7 @@ test imgPhoto-3.5 {ImgPhotoConfigureModel: -data <png>} -constraints {
} -cleanup {
imageCleanup
} -result {20 20}
-test imgPhoto-3.6 {ImgPhotoConfigureModel: -data <default>} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgPhoto-3.6 {ImgPhotoConfigureModel: -data <default>} -setup {
image create photo photo1 -file $teapotPhotoFile
image create photo photo2
} -body {
@@ -354,9 +341,7 @@ test imgPhoto-4.9 {ImgPhotoCmd procedure: configure option} -setup {
} -cleanup {
image delete photo1
} -returnCodes error -result {value for "-gamma" missing}
-test imgPhoto-4.10 {ImgPhotoCmd procedure: copy option} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgPhoto-4.10 {ImgPhotoCmd procedure: copy option} -setup {
image create photo photo1
image create photo photo2 -width 25 -height 30
} -body {
@@ -397,9 +382,7 @@ test imgPhoto-4.14 {ImgPhotoCmd procedure: copy option} -setup {
} -returnCodes error -cleanup {
image delete photo1 photo2
} -result {the "-from" option requires one to four integer values}
-test imgPhoto-4.15 {ImgPhotoCmd procedure: copy option} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgPhoto-4.15 {ImgPhotoCmd procedure: copy option} -setup {
image create photo photo1
image create photo photo2 -file $teapotPhotoFile
} -body {
@@ -409,9 +392,7 @@ test imgPhoto-4.15 {ImgPhotoCmd procedure: copy option} -constraints {
} -cleanup {
image delete photo1 photo2
} -result {60 50 {215 154 120}}
-test imgPhoto-4.16 {ImgPhotoCmd procedure: copy option} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgPhoto-4.16 {ImgPhotoCmd procedure: copy option} -setup {
image create photo photo1
image create photo photo2 -file $teapotPhotoFile
} -body {
@@ -420,9 +401,7 @@ test imgPhoto-4.16 {ImgPhotoCmd procedure: copy option} -constraints {
} -cleanup {
image delete photo1 photo2
} -result {80 100 {19 92 192}}
-test imgPhoto-4.17 {ImgPhotoCmd procedure: copy option} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgPhoto-4.17 {ImgPhotoCmd procedure: copy option} -setup {
image create photo photo1
image create photo photo2 -file $teapotPhotoFile
} -body {
@@ -431,9 +410,7 @@ test imgPhoto-4.17 {ImgPhotoCmd procedure: copy option} -constraints {
} -cleanup {
image delete photo1 photo2
} -result {100 100 {215 154 120}}
-test imgPhoto-4.18 {ImgPhotoCmd procedure: copy option} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgPhoto-4.18 {ImgPhotoCmd procedure: copy option} -setup {
image create photo photo1
image create photo photo2 -file $teapotPhotoFile
} -body {
@@ -442,9 +419,7 @@ test imgPhoto-4.18 {ImgPhotoCmd procedure: copy option} -constraints {
} -cleanup {
image delete photo1 photo2
} -result {120 100 {169 99 47}}
-test imgPhoto-4.19 {ImgPhotoCmd procedure: copy option} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgPhoto-4.19 {ImgPhotoCmd procedure: copy option} -setup {
image create photo photo1
image create photo photo2 -file $teapotPhotoFile
} -body {
@@ -453,9 +428,7 @@ test imgPhoto-4.19 {ImgPhotoCmd procedure: copy option} -constraints {
} -cleanup {
image delete photo1 photo2
} -result {120 100 {169 99 47}}
-test imgPhoto-4.20 {ImgPhotoCmd procedure: copy option} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgPhoto-4.20 {ImgPhotoCmd procedure: copy option} -setup {
image create photo photo1
image create photo photo2 -file $teapotPhotoFile
} -body {
@@ -464,9 +437,7 @@ test imgPhoto-4.20 {ImgPhotoCmd procedure: copy option} -constraints {
} -cleanup {
image delete photo1 photo2
} -result {90 80 {207 146 112}}
-test imgPhoto-4.21 {ImgPhotoCmd procedure: copy option} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgPhoto-4.21 {ImgPhotoCmd procedure: copy option} -setup {
image create photo photo1
image create photo photo2 -file $teapotPhotoFile
} -body {
@@ -488,9 +459,7 @@ test imgPhoto-4.21 {ImgPhotoCmd procedure: copy option} -constraints {
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} -constraints {
- hasTranspTeapotPhoto
-} -setup {
+test imgPhoto-4.22 {ImgPhotoCmd procedure: get option} -setup {
image create photo photo1
} -body {
photo1 read $transpTeapotPhotoFile
@@ -565,9 +534,7 @@ test imgPhoto-4.30 {ImgPhotoCmd procedure: read option} -setup {
} -returnCodes error -cleanup {
image delete photo1
} -result {wrong # args: should be "photo1 read fileName ?-option value ...?"}
-test imgPhoto-4.31 {ImgPhotoCmd procedure: read option} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgPhoto-4.31 {ImgPhotoCmd procedure: read option} -setup {
image create photo photo1
} -body {
photo1 read $teapotPhotoFile -zoom 2
@@ -581,9 +548,7 @@ test imgPhoto-4.32 {ImgPhotoCmd procedure: read option} -setup {
} -cleanup {
image delete photo1
} -result {1 {couldn't open "bogus": no such file or directory}}
-test imgPhoto-4.33 {ImgPhotoCmd procedure: read option} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgPhoto-4.33 {ImgPhotoCmd procedure: read option} -setup {
image create photo photo1
} -body {
photo1 read $teapotPhotoFile -format bogus
@@ -597,9 +562,7 @@ test imgPhoto-4.34 {ImgPhotoCmd procedure: read option} -setup {
} -returnCodes error -cleanup {
image delete photo1
} -result [subst {couldn't recognize data in image file "$README"}]
-test imgPhoto-4.35 {ImgPhotoCmd procedure: read option} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgPhoto-4.35 {ImgPhotoCmd procedure: read option} -setup {
image create photo photo1
} -body {
photo1 read $teapotPhotoFile
@@ -607,9 +570,7 @@ test imgPhoto-4.35 {ImgPhotoCmd procedure: read option} -constraints {
} -cleanup {
image delete photo1
} -result {256 256 {161 109 82}}
-test imgPhoto-4.36 {ImgPhotoCmd procedure: read option} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgPhoto-4.36 {ImgPhotoCmd procedure: read option} -setup {
image create photo photo1
} -body {
photo1 read $teapotPhotoFile -from 0 70 60 120 -to 10 10 -shrink
@@ -943,9 +904,7 @@ test imgPhoto-4.74 {ImgPhotoCmd procedure: put option error handling} -setup {
} -cleanup {
image delete photo1
} -returnCodes 1 -result {wrong # args: should be "photo1 put data ?-option value ...?"}
-test imgPhoto-4.75 {<photo> read command: filename starting with '-'} -constraints {
- hasTeapotPhoto
-} -body {
+test imgPhoto-4.75 {<photo> read command: filename starting with '-'} -body {
file copy -force $teapotPhotoFile -teapotPhotoFile
image create photo photo1
photo1 read -teapotPhotoFile
@@ -953,9 +912,7 @@ test imgPhoto-4.75 {<photo> read command: filename starting with '-'} -constrain
image delete photo1
file delete ./-teapotPhotoFile
} -result {}
-test imgPhoto-4.75.1 {ImgPhotoCmd procedure: copy to same image} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgPhoto-4.75.1 {ImgPhotoCmd procedure: copy to same image} -setup {
imageCleanup
image create photo photo1 -file $teapotPhotoFile
} -body {
@@ -992,9 +949,7 @@ test imgPhoto-4.78 {ImgPhotoCmd, transparency get: normal use} -setup {
} -cleanup {
imageCleanup
} -result {0 255}
-test imgPhoto-4.79 {ImgPhotoCmd, transparency get: no option} -constraints {
- hasTranspTeapotPhoto
-} -setup {
+test imgPhoto-4.79 {ImgPhotoCmd, transparency get: no option} -setup {
image create photo photo1 -file $transpTeapotPhotoFile
set result {}
} -body {
@@ -1007,9 +962,7 @@ test imgPhoto-4.79 {ImgPhotoCmd, transparency get: no option} -constraints {
imageCleanup
} -result {0 1 0 0 0}
# test imgPhoto-4.80: deleted (was transparency get: -boolean)
-test imgPhoto-4.81 {ImgPhotoCmd, transparency get: -alpha} -constraints {
- hasTranspTeapotPhoto
-} -setup {
+test imgPhoto-4.81 {ImgPhotoCmd, transparency get: -alpha} -setup {
image create photo photo1 -file $transpTeapotPhotoFile
set result {}
} -body {
@@ -1103,9 +1056,7 @@ test imgPhoto-4.92 {ImgPhotocmd put: missing data} -setup {
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} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgPhoto-4.93 {ImgPhotoCmd put: data in ppm format} -setup {
image create photo photo1 -file $teapotPhotoFile
image create photo photo2
} -body {
@@ -1337,7 +1288,7 @@ test imgPhoto-4.117 {ImgPhotoCmd data: list colorformat} -setup {
# 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 {
- hasTeapotPhoto hasTranspTeapotPhoto needsTcl867
+ needsTcl867
} -setup {
image create photo teapot -file $teapotPhotoFile
teapot copy teapot -from 50 60 70 80 -shrink
@@ -1370,9 +1321,7 @@ test imgPhoto-4.118 {ImgPhotoCmd data: using data for new image
imageCleanup
} -result {}
-test imgPhoto-5.1 {ImgPhotoGet/Free procedures, shared instances} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgPhoto-5.1 {ImgPhotoGet/Free procedures, shared instances} -setup {
destroy .c
pack [canvas .c]
imageCleanup
@@ -1407,9 +1356,7 @@ test imgPhoto-6.1 {ImgPhotoDisplay procedure, blank display} -setup {
image delete photo1
} -result {}
-test imgPhoto-7.1 {ImgPhotoFree procedure, resource freeing} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgPhoto-7.1 {ImgPhotoFree procedure, resource freeing} -setup {
destroy .c
pack [canvas .c]
imageCleanup
@@ -1422,9 +1369,7 @@ test imgPhoto-7.1 {ImgPhotoFree procedure, resource freeing} -constraints {
} -cleanup {
destroy .c
} -result {}
-test imgPhoto-7.2 {ImgPhotoFree procedures, unlinking} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgPhoto-7.2 {ImgPhotoFree procedures, unlinking} -setup {
deleteWindows
imageCleanup
} -body {
@@ -1447,9 +1392,7 @@ test imgPhoto-7.2 {ImgPhotoFree procedures, unlinking} -constraints {
destroy .c
image delete photo1
} -result {}
-test imgPhoto-7.3 {ImgPhotoFree procedures, multiple visuals} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgPhoto-7.3 {ImgPhotoFree procedures, multiple visuals} -setup {
deleteWindows
imageCleanup
} -body {
@@ -1468,13 +1411,11 @@ test imgPhoto-7.3 {ImgPhotoFree procedures, multiple visuals} -constraints {
image delete photo1
} -result {}
-test imgPhoto-8.1 {ImgPhotoDelete procedure} -constraints hasTeapotPhoto -body {
+test imgPhoto-8.1 {ImgPhotoDelete procedure} -body {
image create photo photo2 -file $teapotPhotoFile
image delete photo2
} -result {}
-test imgPhoto-8.2 {ImgPhotoDelete procedure} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgPhoto-8.2 {ImgPhotoDelete procedure} -setup {
set x {}
} -body {
image create photo photo2 -file $teapotPhotoFile
@@ -1492,9 +1433,7 @@ test imgPhoto-8.3 {ImgPhotoDelete procedure, name cleanup} -body {
imageCleanup
} -result {image "photo2" doesn't exist or is not a photo image}
-test imgPhoto-9.1 {ImgPhotoCmdDeletedProc procedure} -constraints {
- hasTeapotPhoto
-} -body {
+test imgPhoto-9.1 {ImgPhotoCmdDeletedProc procedure} -body {
image create photo photo2 -file $teapotPhotoFile
rename photo2 {}
list [expr {"photo2" in [imageNames]}] [catch {photo2 foo} msg] $msg
@@ -1508,9 +1447,7 @@ test imgPhoto-10.1 {Tk_ImgPhotoPutBlock procedure} -setup {
photo1 put "{#00ff00 #00ff00}" -to 2 0
list [photo1 get 2 0] [photo1 get 3 0] [photo1 get 4 0]
} -result {{0 255 0} {0 255 0} {255 0 0}}
-test imgPhoto-10.2 {Tk_ImgPhotoPutBlock, same source and dest img} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgPhoto-10.2 {Tk_ImgPhotoPutBlock, same source and dest img} -setup {
imageCleanup
} -body {
# Test for bug e4336bef5d
@@ -1522,9 +1459,7 @@ test imgPhoto-10.2 {Tk_ImgPhotoPutBlock, same source and dest img} -constraints
} -cleanup {
imageCleanup
} -result 1
-test imgPhoto-10.3 {Tk_ImgPhotoPutBlock, same source and dest img} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgPhoto-10.3 {Tk_ImgPhotoPutBlock, same source and dest img} -setup {
imageCleanup
} -body {
# Test for bug e4336bef5d
@@ -1555,7 +1490,7 @@ test imgPhoto-11.1 {Tk_FindPhoto} -setup {
imageCleanup
} -returnCodes error -result {image "i1" doesn't exist or is not a photo image}
-test imgPhoto-12.1 {Tk_PhotoPutZoomedBlock} -constraints hasTeapotPhoto -body {
+test imgPhoto-12.1 {Tk_PhotoPutZoomedBlock} -body {
image create photo p3 -file $teapotPhotoFile
set result [list [p3 get 50 50] [p3 get 100 100]]
p3 copy p3 -zoom 2
@@ -1563,9 +1498,7 @@ test imgPhoto-12.1 {Tk_PhotoPutZoomedBlock} -constraints hasTeapotPhoto -body {
} -cleanup {
image delete p3
} -result {{19 92 192} {169 117 90} 512 512 {19 92 192}}
-test imgPhoto-12.2 {Tk_ImgPhotoPutZoomedBlock, same source and dest img} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgPhoto-12.2 {Tk_ImgPhotoPutZoomedBlock, same source and dest img} -setup {
imageCleanup
} -body {
# Test for bug e4336bef5d
@@ -1910,9 +1843,7 @@ test imgPhoto-19.3 {MatchStringFormat: "-format ppm"} -setup {
unset imgData
imageCleanup
} -result {1 2}
-test imgPhoto-19.4 {MatchStringFormat: ppm fmt, without opt} -constraints {
- hasTeapotPhoto
-} -setup {
+test imgPhoto-19.4 {MatchStringFormat: ppm fmt, without opt} -setup {
image create photo photo1 -file $teapotPhotoFile
image create photo photo2
} -body {
@@ -2661,6 +2592,103 @@ test imgPhoto-23.29 {GIF multiple options metadata in -index 1} -setup {
unset -nocomplain gifstart gifdata gifend
+set earthPhotoFile [file join [file dirname [info script]] earth.gif]
+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
+ list [lindex [lindex [gif1 data] 0] 0] [image width gif1] [image height gif1]
+} -cleanup {
+ catch {image delete gif1}
+} -result {{#d8c8b8} 33 35}
+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
+ gif2 copy gif1 -from 152 62 185 97
+ list [lindex [lindex [gif2 data] 0] 0] [image width gif2] [image height gif2]
+} -cleanup {
+ catch {image delete gif1 ; image delete gif2}
+} -result {{#d8c8b8} 33 35}
+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-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
+ list [lindex [lindex [gif1 data] 200] 100] [image width gif1] [image height gif1]
+} -cleanup {
+ catch {image delete gif1}
+} -result {{#d8c8b8} 133 235}
+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
+ list [lindex [lindex [gif1 data] 120] 80] [image width gif1] [image height gif1]
+} -cleanup {
+ catch {image delete gif1}
+} -result {{#d8c8b8} 113 155}
+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
+ list $msg [image width gif1] [image height gif1]
+} -cleanup {
+ catch {image delete gif1}
+} -result {{coordinates for -from option extend outside source image} 0 0}
+unset earthPhotoFile
+
+set ousterPhotoFile [file join [file dirname [info script]] ouster.png]
+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-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
+ list [lindex [lindex [png2 data] 0] 0] [image width png2] [image height png2]
+} -cleanup {
+ catch {image delete png1 ; image delete png2}
+} -result {{#c97962} 33 35}
+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-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-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-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]
+} -cleanup {
+ catch {image delete png1}
+} -result {{coordinates for -from option extend outside source image} 0 0}
+unset ousterPhotoFile
+
catch {rename foreachPixel {}}
catch {rename checkImgTrans {}}
catch {rename checkImgTransLoop {}}
diff --git a/tests/menu.test b/tests/menu.test
index 827f560..72369b5 100644
--- a/tests/menu.test
+++ b/tests/menu.test
@@ -11,9 +11,6 @@ eval tcltest::configure $argv
tcltest::loadTestedCommands
imageInit
-# find the earth.gif file for use in these tests (tests 2.*)
-set earthPhotoFile [file join [file dirname [info script]] earth.gif]
-testConstraint hasEarthPhoto [file exists $earthPhotoFile]
testConstraint pressbutton [llength [info commands pressbutton]]
testConstraint movemouse [llength [info commands movemouse]]
@@ -298,9 +295,8 @@ menu .m2 -tearoff 1
.m1 add checkbutton -label "checkbutton" -variable check -onvalue on -offvalue off
.m1 add radiobutton -label "radiobutton" -variable radio
-if {[testConstraint hasEarthPhoto]} {
- image create photo image1 -file $earthPhotoFile
-}
+set earthPhotoFile [file join [file dirname [info script]] earth.gif]
+image create photo image1 -file $earthPhotoFile
test menu-2.31 {entry configuration options 0 -activebackground #012345 tearoff} -body {
.m1 entryconfigure 0 -activebackground #012345
@@ -700,15 +696,11 @@ test menu-2.120 {entry configuration options 5 -foreground non-existent radiobut
.m1 entryconfigure 5 -foreground non-existent
} -returnCodes error -result {unknown color name "non-existent"}
-test menu-2.121 {entry configuration options 0 -image image1 tearoff} -constraints {
- hasEarthPhoto
-} -body {
+test menu-2.121 {entry configuration options 0 -image image1 tearoff} -body {
.m1 entryconfigure 0 -image image1
} -returnCodes error -result {unknown option "-image"}
-test menu-2.122 {entry configuration options 1 -image image1 command} -constraints {
- hasEarthPhoto
-} -setup {
+test menu-2.122 {entry configuration options 1 -image image1 command} -setup {
.m1 entryconfigure 1 -image {}
} -body {
.m1 entryconfigure 1 -image image1
@@ -717,9 +709,7 @@ test menu-2.122 {entry configuration options 1 -image image1 command} -constrain
.m1 entryconfigure 1 -image {}
} -result {image1}
-test menu-2.123 {entry configuration options 2 -image image1 cascade} -constraints {
- hasEarthPhoto
-} -setup {
+test menu-2.123 {entry configuration options 2 -image image1 cascade} -setup {
.m1 entryconfigure 2 -image {}
} -body {
.m1 entryconfigure 2 -image image1
@@ -728,15 +718,11 @@ test menu-2.123 {entry configuration options 2 -image image1 cascade} -constrain
.m1 entryconfigure 2 -image {}
} -result {image1}
-test menu-2.124 {entry configuration options 3 -image image1 separator} -constraints {
- hasEarthPhoto
-} -body {
+test menu-2.124 {entry configuration options 3 -image image1 separator} -body {
.m1 entryconfigure 3 -image image1
} -returnCodes error -result {unknown option "-image"}
-test menu-2.125 {entry configuration options 4 -image image1 checkbutton} -constraints {
- hasEarthPhoto
-} -setup {
+test menu-2.125 {entry configuration options 4 -image image1 checkbutton} -setup {
.m1 entryconfigure 4 -image {}
} -body {
.m1 entryconfigure 4 -image image1
@@ -745,9 +731,7 @@ test menu-2.125 {entry configuration options 4 -image image1 checkbutton} -const
.m1 entryconfigure 4 -image {}
} -result {image1}
-test menu-2.126 {entry configuration options 5 -image image1 radiobutton} -constraints {
- hasEarthPhoto
-} -setup {
+test menu-2.126 {entry configuration options 5 -image image1 radiobutton} -setup {
.m1 entryconfigure 5 -image {}
} -body {
.m1 entryconfigure 5 -image image1
@@ -991,33 +975,23 @@ test menu-2.180 {entry configuration options 5 -selectcolor non-existent radiobu
.m1 entryconfigure 5 -selectcolor non-existent
} -returnCodes error -result {unknown color name "non-existent"}
-test menu-2.181 {entry configuration options 0 -selectimage image1 tearoff} -constraints {
- hasEarthPhoto
-} -body {
+test menu-2.181 {entry configuration options 0 -selectimage image1 tearoff} -body {
.m1 entryconfigure 0 -selectimage image1
} -returnCodes error -result {unknown option "-selectimage"}
-test menu-2.182 {entry configuration options 1 -selectimage image1 command} -constraints {
- hasEarthPhoto
-} -body {
+test menu-2.182 {entry configuration options 1 -selectimage image1 command} -body {
.m1 entryconfigure 1 -selectimage image1
} -returnCodes error -result {unknown option "-selectimage"}
-test menu-2.183 {entry configuration options 2 -selectimage image1 cascade} -constraints {
- hasEarthPhoto
-} -body {
+test menu-2.183 {entry configuration options 2 -selectimage image1 cascade} -body {
.m1 entryconfigure 2 -selectimage image1
} -returnCodes error -result {unknown option "-selectimage"}
-test menu-2.184 {entry configuration options 3 -selectimage image1 separator} -constraints {
- hasEarthPhoto
-} -body {
+test menu-2.184 {entry configuration options 3 -selectimage image1 separator} -body {
.m1 entryconfigure 3 -selectimage image1
} -returnCodes error -result {unknown option "-selectimage"}
-test menu-2.185 {entry configuration options 4 -selectimage image1 checkbutton} -constraints {
- hasEarthPhoto
-} -setup {
+test menu-2.185 {entry configuration options 4 -selectimage image1 checkbutton} -setup {
.m1 entryconfigure 4 -selectimage {}
} -body {
.m1 entryconfigure 4 -selectimage image1
@@ -1026,9 +1000,7 @@ test menu-2.185 {entry configuration options 4 -selectimage image1 checkbutton}
.m1 entryconfigure 4 -selectimage {}
} -result {image1}
-test menu-2.186 {entry configuration options 5 -selectimage image1 radiobutton} -constraints {
- hasEarthPhoto
-} -setup {
+test menu-2.186 {entry configuration options 5 -selectimage image1 radiobutton} -setup {
.m1 entryconfigure 5 -selectimage {}
} -body {
.m1 entryconfigure 5 -selectimage image1
@@ -1220,10 +1192,7 @@ test menu-2.228 {entry configuration options 5 -underline 3p radiobutton} -body
} -returnCodes error -result {bad index "3p": must be integer?[+-]integer?, end?[+-]integer?, or ""}
deleteWindows
-if {[testConstraint hasEarthPhoto]} {
- image delete image1
-}
-
+image delete image1
test menu-3.1 {MenuWidgetCmd procedure} -setup {
@@ -2347,7 +2316,7 @@ test menu-8.1 {DestroyMenuEntry} -setup {
.m1 add cascade -menu .m2
list [.m1 delete 1] [destroy .m1 .m2]
} -result {{} {}}
-test menu-8.2 {DestroyMenuEntry} -constraints hasEarthPhoto -setup {
+test menu-8.2 {DestroyMenuEntry} -setup {
deleteWindows
catch {image delete image1a}
} -body {
@@ -2688,7 +2657,7 @@ test menu-11.18 {ConfigureMenuEntry} -constraints testImageType -setup {
imageCleanup
} -result {}
test menu-11.19 {ConfigureMenuEntry} -constraints {
- testImageType hasEarthPhoto
+ testImageType
} -setup {
deleteWindows
imageCleanup
@@ -2703,7 +2672,7 @@ test menu-11.19 {ConfigureMenuEntry} -constraints {
imageCleanup
} -result {}
test menu-11.20 {ConfigureMenuEntry} -constraints {
- testImageType hasEarthPhoto
+ testImageType
} -setup {
deleteWindows
imageCleanup
@@ -2718,7 +2687,7 @@ test menu-11.20 {ConfigureMenuEntry} -constraints {
imageCleanup
} -result {}
test menu-11.21 {ConfigureMenuEntry} -constraints {
- testImageType hasEarthPhoto
+ testImageType
} -setup {
deleteWindows
imageCleanup
@@ -2734,6 +2703,8 @@ test menu-11.21 {ConfigureMenuEntry} -constraints {
imageCleanup
} -result {}
+unset earthPhotoFile
+
test menu-12.1 {ConfigureMenuCloneEntries} -setup {
deleteWindows
diff --git a/tests/ouster.png b/tests/ouster.png
new file mode 100644
index 0000000..259b8f9
--- /dev/null
+++ b/tests/ouster.png
Binary files differ