diff options
| -rw-r--r-- | ChangeLog | 8 | ||||
| -rw-r--r-- | doc/photo.n | 27 | ||||
| -rw-r--r-- | generic/tkImgPhoto.c | 363 | ||||
| -rw-r--r-- | tests/imgPhoto.test | 145 |
4 files changed, 427 insertions, 116 deletions
@@ -1,3 +1,11 @@ +2002-02-01 Donal K. Fellows <fellowsd@cs.man.ac.uk> + + * doc/photo.n: Documented transparency subcommand. + * tests/imgPhoto.test (imgPhoto-4.40...imgPhoto-4.68): Tests for + the transparency subcommand. + * generic/tkImgPhoto.c (ImgPhotoCmd): Added transparency + subcommand (see TIP #14.) + 2002-01-31 Todd Helfter <tmh@users.sourceforge.net> * generic/tkMenu.c (ConfigureMenuCloneEntries) * tests/menu.test (menu3.68) diff --git a/doc/photo.n b/doc/photo.n index 5840473..32b4a69 100644 --- a/doc/photo.n +++ b/doc/photo.n @@ -9,7 +9,7 @@ '\" Department of Computer Science, '\" Australian National University. '\" -'\" RCS: @(#) $Id: photo.n,v 1.7 2001/02/13 21:52:45 ericm Exp $ +'\" RCS: @(#) $Id: photo.n,v 1.8 2002/02/01 14:27:30 dkf Exp $ '\" .so man.macros .TH photo n 4.0 Tk "Tk Built-In Commands" @@ -31,7 +31,11 @@ can be supplied from C code through a procedural interface. At present, only GIF and PPM/PGM formats are supported, but an interface exists to allow additional image file formats to be added easily. A photo image is transparent -in regions where no image data has been supplied. +in regions where no image data has been supplied +.VS 8.4 +or where it has been set transparent by the \fBtransparency set\fB +subcommand. +.VE 8.4 .SH "CREATING PHOTOS" .PP @@ -308,6 +312,21 @@ not noticeable, but if it is a problem, this command can be used to recalculate the dithered image in each window where the image is displayed. .TP +\fIimageName \fBtransparency \fIsubcommand ?arg arg ...?\fR +.VS 8.4 +Allows examination and manipulation of the transparency information in +the photo image. Several subcommands are available: +.RS +.TP +\fIimageName \fBtransparency get \fIx y\fR +Returns a boolean indicating if the pixel at (\fIx\fR,\fIy\fR) is +transparent. +\fIimageName \fBtransparency get \fIx y boolean\fR +Makes the pixel at (\fIx\fR,\fIy\fR) transparent if \fIboolean\fR is +true, and makes that pixel opaque otherwise. +.RE +.VE 8.4 +.TP \fIimageName \fBwrite \fIfilename\fR ?\fIoption value(s) ...\fR? Writes image data from \fIimageName\fR to a file named \fIfilename\fR. The following options may be specified: @@ -367,6 +386,10 @@ for the \fB\-format\fR option must begin with the complete name of the requested handler, and may contain additional information following that, which the handler can use, for example, to specify which variant to use of the formats supported by the handler. +.VS 8.4 +Note that not all image handlers may support writing transparency data +to a file, even where the target image format does. +.VE 8.4 .SH "COLOR ALLOCATION" .PP diff --git a/generic/tkImgPhoto.c b/generic/tkImgPhoto.c index 59f6087..b1a7fc0 100644 --- a/generic/tkImgPhoto.c +++ b/generic/tkImgPhoto.c @@ -7,6 +7,7 @@ * * Copyright (c) 1994 The Australian National University. * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 2002 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -15,7 +16,7 @@ * Department of Computer Science, * Australian National University. * - * RCS: @(#) $Id: tkImgPhoto.c,v 1.27 2002/01/25 21:09:37 dgp Exp $ + * RCS: @(#) $Id: tkImgPhoto.c,v 1.28 2002/02/01 14:27:30 dkf Exp $ */ #include "tkInt.h" @@ -565,11 +566,12 @@ ImgPhotoCmd(clientData, interp, objc, objv) int oldformat = 0; static CONST char *photoOptions[] = { "blank", "cget", "configure", "copy", "data", "get", "put", - "read", "redither", "write", (char *) NULL + "read", "redither", "transparency", "write", (char *) NULL }; enum options { PHOTO_BLANK, PHOTO_CGET, PHOTO_CONFIGURE, PHOTO_COPY, PHOTO_DATA, - PHOTO_GET, PHOTO_PUT, PHOTO_READ, PHOTO_REDITHER, PHOTO_WRITE + PHOTO_GET, PHOTO_PUT, PHOTO_READ, PHOTO_REDITHER, PHOTO_TRANS, + PHOTO_WRITE }; PhotoMaster *masterPtr = (PhotoMaster *) clientData; @@ -607,8 +609,9 @@ ImgPhotoCmd(clientData, interp, objc, objv) } return proc(clientData, interp, objc, objv); } + switch ((enum options) index) { - case PHOTO_BLANK: { + case PHOTO_BLANK: /* * photo blank command - just call Tk_PhotoBlank. */ @@ -620,9 +623,10 @@ ImgPhotoCmd(clientData, interp, objc, objv) return TCL_ERROR; } break; - } - case PHOTO_CGET: { + + case PHOTO_CGET: { char *arg; + if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "option"); return TCL_ERROR; @@ -643,8 +647,9 @@ ImgPhotoCmd(clientData, interp, objc, objv) Tk_ConfigureValue(interp, Tk_MainWindow(interp), configSpecs, (char *) masterPtr, Tcl_GetString(objv[2]), 0); break; - } - case PHOTO_CONFIGURE: { + } + + case PHOTO_CONFIGURE: /* * photo configure command - handle this in the standard way. */ @@ -676,39 +681,38 @@ ImgPhotoCmd(clientData, interp, objc, objv) return TCL_OK; } if (objc == 3) { - char *arg = Tcl_GetStringFromObj(objv[2], (int *) &length); - if (!strncmp(arg, "-data", length)) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "-data {} {} {}", (char *) NULL); - if (masterPtr->dataString) { - Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp), - masterPtr->dataString); - } else { + char *arg = Tcl_GetStringFromObj(objv[2], (int *) &length); + if (!strncmp(arg, "-data", length)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - " {}", (char *) NULL); - } - return TCL_OK; - } else if (!strncmp(arg, "-format", length)) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "-format {} {} {}", (char *) NULL); - if (masterPtr->format) { - Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp), - masterPtr->format); - } else { + "-data {} {} {}", (char *) NULL); + if (masterPtr->dataString) { + Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp), + masterPtr->dataString); + } else { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + " {}", (char *) NULL); + } + return TCL_OK; + } else if (!strncmp(arg, "-format", length)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - " {}", (char *) NULL); + "-format {} {} {}", (char *) NULL); + if (masterPtr->format) { + Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp), + masterPtr->format); + } else { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + " {}", (char *) NULL); + } + return TCL_OK; + } else { + return Tk_ConfigureInfo(interp, Tk_MainWindow(interp), + configSpecs, (char *) masterPtr, arg, 0); } - return TCL_OK; - } else { - return Tk_ConfigureInfo(interp, Tk_MainWindow(interp), - configSpecs, (char *) masterPtr, arg, 0); - } } return ImgPhotoConfigureMaster(interp, masterPtr, objc-2, objv+2, TK_CONFIG_ARGV_ONLY); - break; - } - case PHOTO_COPY: { + + case PHOTO_COPY: /* * photo copy command - first parse options. */ @@ -734,7 +738,8 @@ ImgPhotoCmd(clientData, interp, objc, objv) * Check the values given for the -from option. */ - if ((srcHandle = Tk_FindPhoto(interp, Tcl_GetString(options.name))) == NULL) { + srcHandle = Tk_FindPhoto(interp, Tcl_GetString(options.name)); + if (srcHandle == NULL) { Tcl_AppendResult(interp, "image \"", Tcl_GetString(options.name), "\" doesn't", " exist or is not a photo image", (char *) NULL); @@ -753,11 +758,11 @@ ImgPhotoCmd(clientData, interp, objc, objv) * Fill in default values for unspecified parameters. */ - if (((options.options & OPT_FROM) == 0) || (options.fromX2 < 0)) { + if (!(options.options & OPT_FROM) || (options.fromX2 < 0)) { options.fromX2 = block.width; options.fromY2 = block.height; } - if (((options.options & OPT_TO) == 0) || (options.toX2 < 0)) { + if (!(options.options & OPT_TO) || (options.toX2 < 0)) { width = options.fromX2 - options.fromX; if (options.subsampleX > 0) { width = (width + options.subsampleX - 1) / options.subsampleX; @@ -794,7 +799,7 @@ ImgPhotoCmd(clientData, interp, objc, objv) */ block.pixelPtr += options.fromX * block.pixelSize - + options.fromY * block.pitch; + + options.fromY * block.pitch; block.width = options.fromX2 - options.fromX; block.height = options.fromY2 - options.fromY; Tk_PhotoPutZoomedBlock((Tk_PhotoHandle) masterPtr, &block, @@ -803,8 +808,8 @@ ImgPhotoCmd(clientData, interp, objc, objv) options.subsampleX, options.subsampleY); break; - } - case PHOTO_DATA: { + + case PHOTO_DATA: { char *data; /* @@ -877,7 +882,7 @@ ImgPhotoCmd(clientData, interp, objc, objv) data = ImgGetPhoto(masterPtr, &block, &options); - result = ((int (*) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *formatString, + result = ((int (*) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *formatString, Tk_PhotoImageBlock *blockPtr, VOID *dummy))) stringWriteProc) (interp, options.format, &block, (VOID *) NULL); if (options.background) { @@ -889,6 +894,7 @@ ImgPhotoCmd(clientData, interp, objc, objv) return result; break; } + case PHOTO_GET: { /* * photo get command - first parse and check parameters. @@ -921,7 +927,8 @@ ImgPhotoCmd(clientData, interp, objc, objv) Tcl_AppendResult(interp, string, (char *) NULL); break; } - case PHOTO_PUT: { + + case PHOTO_PUT: /* * photo put command - first parse the options and colors specified. */ @@ -930,7 +937,7 @@ ImgPhotoCmd(clientData, interp, objc, objv) memset((VOID *) &options, 0, sizeof(options)); options.name = NULL; if (ParseSubcommandOptions(&options, interp, OPT_TO|OPT_FORMAT, - &index, objc, objv) != TCL_OK) { + &index, objc, objv) != TCL_OK) { return TCL_ERROR; } if ((options.name == NULL) || (index < objc)) { @@ -941,8 +948,8 @@ ImgPhotoCmd(clientData, interp, objc, objv) if (MatchStringFormat(interp, options.name ? objv[2]:NULL, options.format, &imageFormat, &imageWidth, &imageHeight, &oldformat) == TCL_OK) { - Tcl_Obj *format; - Tcl_Obj *data; + Tcl_Obj *format, *data; + if (((options.options & OPT_TO) == 0) || (options.toX2 < 0)) { options.toX2 = options.toX + imageWidth; options.toY2 = options.toY + imageHeight; @@ -963,8 +970,8 @@ ImgPhotoCmd(clientData, interp, objc, objv) } if ((*imageFormat->stringReadProc)(interp, data, format, (Tk_PhotoHandle) masterPtr, - options.toX, options.toY, imageWidth, imageHeight, 0, 0) - != TCL_OK) { + options.toX, options.toY, imageWidth, imageHeight, + 0, 0) != TCL_OK) { return TCL_ERROR; } masterPtr->flags |= IMAGE_CHANGED; @@ -975,8 +982,7 @@ ImgPhotoCmd(clientData, interp, objc, objv) } Tcl_ResetResult(interp); if (Tcl_SplitList(interp, Tcl_GetString(options.name), - &dataHeight, &srcArgv) - != TCL_OK) { + &dataHeight, &srcArgv) != TCL_OK) { return TCL_ERROR; } tkwin = Tk_MainWindow(interp); @@ -990,17 +996,14 @@ ImgPhotoCmd(clientData, interp, objc, objv) } if (y == 0) { dataWidth = listArgc; - pixelPtr = (unsigned char *) ckalloc((unsigned) - dataWidth * dataHeight * 3); + pixelPtr = (unsigned char *) + ckalloc((unsigned) dataWidth * dataHeight * 3); block.pixelPtr = pixelPtr; - } else { - if (listArgc != dataWidth) { - Tcl_AppendResult(interp, "all elements of color list must", - " have the same number of elements", - (char *) NULL); - ckfree((char *) listArgv); - break; - } + } else if (listArgc != dataWidth) { + Tcl_AppendResult(interp, "all elements of color list must", + " have the same number of elements", (char *) NULL); + ckfree((char *) listArgv); + break; } for (x = 0; x < dataWidth; ++x) { if (!XParseColor(Tk_Display(tkwin), Tk_Colormap(tkwin), @@ -1014,8 +1017,9 @@ ImgPhotoCmd(clientData, interp, objc, objv) *pixelPtr++ = color.blue >> 8; } ckfree((char *) listArgv); - if (x < dataWidth) + if (x < dataWidth) { break; + } } ckfree((char *) srcArgv); if (y < dataHeight || dataHeight == 0 || dataWidth == 0) { @@ -1033,7 +1037,7 @@ ImgPhotoCmd(clientData, interp, objc, objv) * copy the block in using Tk_PhotoPutBlock. */ - if (((options.options & OPT_TO) == 0) || (options.toX2 < 0)) { + if (!(options.options & OPT_TO) || (options.toX2 < 0)) { options.toX2 = options.toX + dataWidth; options.toY2 = options.toY + dataHeight; } @@ -1050,13 +1054,14 @@ ImgPhotoCmd(clientData, interp, objc, objv) options.toY2 - options.toY); ckfree((char *) block.pixelPtr); break; - } - case PHOTO_READ: { + + case PHOTO_READ: { + Tcl_Obj *format; + /* * photo read command - first parse the options specified. */ - Tcl_Obj *format; index = 2; memset((VOID *) &options, 0, sizeof(options)); options.name = NULL; @@ -1067,8 +1072,7 @@ ImgPhotoCmd(clientData, interp, objc, objv) return TCL_ERROR; } if ((options.name == NULL) || (index < objc)) { - Tcl_WrongNumArgs(interp, 2, objv, - "fileName ?options?"); + Tcl_WrongNumArgs(interp, 2, objv, "fileName ?options?"); return TCL_ERROR; } @@ -1078,7 +1082,7 @@ ImgPhotoCmd(clientData, interp, objc, objv) if (Tcl_IsSafe(interp)) { Tcl_AppendResult(interp, "can't get image from a file in a", - " safe interpreter", (char *) NULL); + " safe interpreter", (char *) NULL); return TCL_ERROR; } @@ -1103,8 +1107,8 @@ ImgPhotoCmd(clientData, interp, objc, objv) } if (MatchFileFormat(interp, chan, - Tcl_GetString(options.name), options.format, - &imageFormat, &imageWidth, &imageHeight, &oldformat) != TCL_OK) { + Tcl_GetString(options.name), options.format, &imageFormat, + &imageWidth, &imageHeight, &oldformat) != TCL_OK) { Tcl_Close(NULL, chan); return TCL_ERROR; } @@ -1156,42 +1160,179 @@ ImgPhotoCmd(clientData, interp, objc, objv) } return result; break; - } - case PHOTO_REDITHER: { - if (objc == 2) { + } + + case PHOTO_REDITHER: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL); + return TCL_ERROR; + } + + /* + * Call Dither if any part of the image is not correctly + * dithered at present. + */ + + x = masterPtr->ditherX; + y = masterPtr->ditherY; + if (masterPtr->ditherX != 0) { + Tk_DitherPhoto((Tk_PhotoHandle) masterPtr, x, y, + masterPtr->width - x, 1); + } + if (masterPtr->ditherY < masterPtr->height) { + x = 0; + Tk_DitherPhoto((Tk_PhotoHandle)masterPtr, 0, + masterPtr->ditherY, masterPtr->width, + masterPtr->height - masterPtr->ditherY); + } + + if (y < masterPtr->height) { /* - * Call Dither if any part of the image is not correctly - * dithered at present. + * Tell the core image code that part of the image has changed. */ - x = masterPtr->ditherX; - y = masterPtr->ditherY; - if (masterPtr->ditherX != 0) { - Tk_DitherPhoto((Tk_PhotoHandle) masterPtr, x, y, masterPtr->width - x, 1); + Tk_ImageChanged(masterPtr->tkMaster, x, y, + (masterPtr->width - x), (masterPtr->height - y), + masterPtr->width, masterPtr->height); + } + break; + + case PHOTO_TRANS: { + static CONST char *photoTransOptions[] = { + "get", "set", (char *) NULL + }; + enum transOptions { + PHOTO_TRANS_GET, PHOTO_TRANS_SET + }; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "option ?arg arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[2], photoTransOptions, "option", + 0, &index) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum transOptions) index) { + case PHOTO_TRANS_GET: { + XRectangle testBox; + TkRegion testRegion; + + if (objc != 5) { + Tcl_WrongNumArgs(interp, 3, objv, "x y"); + return TCL_ERROR; + } + if ((Tcl_GetIntFromObj(interp, objv[3], &x) != TCL_OK) + || (Tcl_GetIntFromObj(interp, objv[4], &y) != TCL_OK)) { + return TCL_ERROR; + } + if ((x < 0) || (x >= masterPtr->width) + || (y < 0) || (y >= masterPtr->height)) { + Tcl_AppendResult(interp, Tcl_GetString(objv[0]), + " transparency get: coordinates out of range", + (char *) NULL); + return TCL_ERROR; + } + + testBox.x = x; + testBox.y = y; + testBox.width = 1; + testBox.height = 1; + /* What a way to do a test! */ + testRegion = TkCreateRegion(); + TkUnionRectWithRegion(&testBox, testRegion, testRegion); + TkIntersectRegion(testRegion, masterPtr->validRegion, testRegion); + TkClipBox(testRegion, &testBox); + TkDestroyRegion(testRegion); + + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), + (testBox.width==0 && testBox.height==0)); + return TCL_OK; + } + + case PHOTO_TRANS_SET: { + int transFlag; + XRectangle setBox; + + if (objc != 6) { + Tcl_WrongNumArgs(interp, 3, objv, "x y boolean"); + return TCL_ERROR; } - if (masterPtr->ditherY < masterPtr->height) { - x = 0; - Tk_DitherPhoto((Tk_PhotoHandle)masterPtr, 0, masterPtr->ditherY, masterPtr->width, - masterPtr->height - masterPtr->ditherY); + if ((Tcl_GetIntFromObj(interp, objv[3], &x) != TCL_OK) + || (Tcl_GetIntFromObj(interp, objv[4], &y) != TCL_OK) + || (Tcl_GetBooleanFromObj(interp, objv[5], + &transFlag) != TCL_OK)) { + return TCL_ERROR; + } + if ((x < 0) || (x >= masterPtr->width) + || (y < 0) || (y >= masterPtr->height)) { + Tcl_AppendResult(interp, Tcl_GetString(objv[0]), + " transparency set: coordinates out of range", + (char *) NULL); + return TCL_ERROR; } - if (y < masterPtr->height) { + if (transFlag) { /* - * Tell the core image code that part of the image has changed. + * Make pixel transparent. Do by building a mask for + * all the other pixels in the image and setting the + * validRegion to the intersection of that with the + * old validRegion. There isn't a neater way to do + * this given the limited set of operations available + * in the platform-independent region operations. */ - - Tk_ImageChanged(masterPtr->tkMaster, x, y, - (masterPtr->width - x), (masterPtr->height - y), - masterPtr->width, masterPtr->height); + TkRegion setRegion = TkCreateRegion(); + + if (y > 0) { + setBox.x = 0; + setBox.y = 0; + setBox.width = masterPtr->width; + setBox.height = y; + TkUnionRectWithRegion(&setBox, setRegion, setRegion); + } + if (x > 0) { + setBox.x = 0; + setBox.y = y; + setBox.width = x; + setBox.height = 1; + TkUnionRectWithRegion(&setBox, setRegion, setRegion); + } + if (x < masterPtr->width-1) { + setBox.x = x+1; + setBox.y = y; + setBox.width = masterPtr->width-1 - x; + setBox.height = 1; + TkUnionRectWithRegion(&setBox, setRegion, setRegion); + } + if (y < masterPtr->height-1) { + setBox.x = 0; + setBox.y = y+1; + setBox.width = masterPtr->width; + setBox.height = masterPtr->height-1 - y; + TkUnionRectWithRegion(&setBox, setRegion, setRegion); + } + TkIntersectRegion(masterPtr->validRegion, setRegion, + masterPtr->validRegion); + TkDestroyRegion(setRegion); + } else { + /* + * Make pixel opaque. + */ + setBox.x = x; + setBox.y = y; + setBox.width = 1; + setBox.height = 1; + TkUnionRectWithRegion(&setBox, masterPtr->validRegion, + masterPtr->validRegion); } + } - } else { - Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL); - return TCL_ERROR; } - break; - } - case PHOTO_WRITE: { + return TCL_OK; + } + + case PHOTO_WRITE: { char *data; Tcl_Obj *format; @@ -1201,7 +1342,7 @@ ImgPhotoCmd(clientData, interp, objc, objv) if (Tcl_IsSafe(interp)) { Tcl_AppendResult(interp, "can't write image to a file in a", - " safe interpreter", (char *) NULL); + " safe interpreter", (char *) NULL); return TCL_ERROR; } @@ -1235,7 +1376,7 @@ ImgPhotoCmd(clientData, interp, objc, objv) * Fill in default values for unspecified parameters. */ - if (((options.options & OPT_FROM) == 0) || (options.fromX2 < 0)) { + if (!(options.options & OPT_FROM) || (options.fromX2 < 0)) { options.fromX2 = masterPtr->width; options.fromY2 = masterPtr->height; } @@ -1247,7 +1388,7 @@ ImgPhotoCmd(clientData, interp, objc, objv) matched = 0; for (imageFormat = tsdPtr->formatList; imageFormat != NULL; - imageFormat = imageFormat->nextPtr) { + imageFormat = imageFormat->nextPtr) { if ((options.format == NULL) || (strncasecmp(Tcl_GetString(options.format), imageFormat->name, strlen(imageFormat->name)) == 0)) { @@ -1258,18 +1399,18 @@ ImgPhotoCmd(clientData, interp, objc, objv) } } if (imageFormat == NULL) { - oldformat = 1; - for (imageFormat = tsdPtr->oldFormatList; imageFormat != NULL; - imageFormat = imageFormat->nextPtr) { - if ((options.format == NULL) - || (strncasecmp(Tcl_GetString(options.format), - imageFormat->name, strlen(imageFormat->name)) == 0)) { - matched = 1; - if (imageFormat->fileWriteProc != NULL) { - break; + oldformat = 1; + for (imageFormat = tsdPtr->oldFormatList; imageFormat != NULL; + imageFormat = imageFormat->nextPtr) { + if ((options.format == NULL) + || (strncasecmp(Tcl_GetString(options.format), + imageFormat->name, strlen(imageFormat->name)) == 0)) { + matched = 1; + if (imageFormat->fileWriteProc != NULL) { + break; + } } } - } } if (imageFormat == NULL) { if (options.format == NULL) { @@ -1299,8 +1440,7 @@ ImgPhotoCmd(clientData, interp, objc, objv) format = (Tcl_Obj *) Tcl_GetString(options.format); } result = (*imageFormat->fileWriteProc)(interp, - Tcl_GetString(options.name), - format, &block); + Tcl_GetString(options.name), format, &block); if (options.background) { Tk_FreeColor(options.background); } @@ -1308,10 +1448,9 @@ ImgPhotoCmd(clientData, interp, objc, objv) ckfree(data); } return result; - break; - } } + } return TCL_OK; } diff --git a/tests/imgPhoto.test b/tests/imgPhoto.test index 0bad47f..320b289 100644 --- a/tests/imgPhoto.test +++ b/tests/imgPhoto.test @@ -9,7 +9,7 @@ # # Author: Paul Mackerras (paulus@cs.anu.edu.au) # -# RCS: @(#) $Id: imgPhoto.test,v 1.8 2000/07/05 23:30:07 ericm Exp $ +# RCS: @(#) $Id: imgPhoto.test,v 1.9 2002/02/01 14:27:30 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] @@ -134,7 +134,7 @@ test imgPhoto-4.1 {ImgPhotoCmd procedure} { } {1 {wrong # args: should be "p1 option ?arg arg ...?"}} test imgPhoto-4.2 {ImgPhotoCmd procedure} { list [catch {p1 blah} err] $err -} {1 {bad option "blah": must be blank, cget, configure, copy, data, get, put, read, redither, or write}} +} {1 {bad option "blah": must be blank, cget, configure, copy, data, get, put, read, redither, transparency, or write}} test imgPhoto-4.3 {ImgPhotoCmd procedure: blank option} { p1 blank list [catch {p1 blank x} err] $err @@ -277,6 +277,147 @@ test imgPhoto-4.38 {ImgPhotoCmd procedure: write option} { test imgPhoto-4.39 {ImgPhotoCmd procedure: write option} { list [catch {p1 write teapot.tmp -format bogus} err] $err } {1 {image file format "bogus" is unknown}} +eval image delete [image names] +image create photo p1 +test imgPhoto-4.40 {ImgPhotoCmd procedure: transparency option} { + list [catch {p1 transparency} err] $err +} {1 {wrong # args: should be "p1 transparency option ?arg arg ...?"}} +test imgPhoto-4.41 {ImgPhotoCmd procedure: transparency get option} { + list [catch {p1 transparency get} err] $err +} {1 {wrong # args: should be "p1 transparency get x y"}} +test imgPhoto-4.42 {ImgPhotoCmd procedure: transparency get option} { + list [catch {p1 transparency get 0} err] $err +} {1 {wrong # args: should be "p1 transparency get x y"}} +test imgPhoto-4.43 {ImgPhotoCmd procedure: transparency get option} { + list [catch {p1 transparency get 0 0 0} err] $err +} {1 {wrong # args: should be "p1 transparency get x y"}} +test imgPhoto-4.44 {ImgPhotoCmd procedure: transparency get option} { + list [catch {p1 transparency get bogus 0} err] $err +} {1 {expected integer but got "bogus"}} +test imgPhoto-4.45 {ImgPhotoCmd procedure: transparency get option} { + list [catch {p1 transparency get 0 bogus} err] $err +} {1 {expected integer but got "bogus"}} +test imgPhoto-4.46 {ImgPhotoCmd procedure: transparency get option} { + p1 put white + p1 transparency get 0 0 +} 0 +test imgPhoto-4.47 {ImgPhotoCmd procedure: transparency get option} { + list [catch {p1 transparency get 1 0} err] $err +} {1 {p1 transparency get: coordinates out of range}} +test imgPhoto-4.48 {ImgPhotoCmd procedure: transparency get option} { + list [catch {p1 transparency get -1 0} err] $err +} {1 {p1 transparency get: coordinates out of range}} +test imgPhoto-4.49 {ImgPhotoCmd procedure: transparency get option} { + list [catch {p1 transparency get 0 1} err] $err +} {1 {p1 transparency get: coordinates out of range}} +test imgPhoto-4.50 {ImgPhotoCmd procedure: transparency get option} { + list [catch {p1 transparency get 0 -1} err] $err +} {1 {p1 transparency get: coordinates out of range}} +test imgPhoto-4.51 {ImgPhotoCmd procedure: transparency get option} { + p1 blank + p1 transparency get 0 0 +} 1 +test imgPhoto-4.52 {ImgPhotoCmd procedure: transparency set option} { + list [catch {p1 transparency set} err] $err +} {1 {wrong # args: should be "p1 transparency set x y boolean"}} +test imgPhoto-4.53 {ImgPhotoCmd procedure: transparency set option} { + list [catch {p1 transparency set 0} err] $err +} {1 {wrong # args: should be "p1 transparency set x y boolean"}} +test imgPhoto-4.54 {ImgPhotoCmd procedure: transparency set option} { + list [catch {p1 transparency set 0 0} err] $err +} {1 {wrong # args: should be "p1 transparency set x y boolean"}} +test imgPhoto-4.55 {ImgPhotoCmd procedure: transparency set option} { + list [catch {p1 transparency set 0 0 0 0} err] $err +} {1 {wrong # args: should be "p1 transparency set x y boolean"}} +test imgPhoto-4.56 {ImgPhotoCmd procedure: transparency set option} { + list [catch {p1 transparency set bogus 0 0} err] $err +} {1 {expected integer but got "bogus"}} +test imgPhoto-4.57 {ImgPhotoCmd procedure: transparency set option} { + list [catch {p1 transparency set 0 bogus 0} err] $err +} {1 {expected integer but got "bogus"}} +test imgPhoto-4.58 {ImgPhotoCmd procedure: transparency set option} { + list [catch {p1 transparency set 0 0 bogus} err] $err +} {1 {expected boolean value but got "bogus"}} +test imgPhoto-4.59 {ImgPhotoCmd procedure: transparency set option} { + list [catch {p1 transparency set 1 0 0} err] $err +} {1 {p1 transparency set: coordinates out of range}} +test imgPhoto-4.60 {ImgPhotoCmd procedure: transparency set option} { + list [catch {p1 transparency set -1 0 0} err] $err +} {1 {p1 transparency set: coordinates out of range}} +test imgPhoto-4.61 {ImgPhotoCmd procedure: transparency set option} { + list [catch {p1 transparency set 0 1 0} err] $err +} {1 {p1 transparency set: coordinates out of range}} +test imgPhoto-4.62 {ImgPhotoCmd procedure: transparency set option} { + list [catch {p1 transparency set 0 -1 0} err] $err +} {1 {p1 transparency set: coordinates out of range}} +test imgPhoto-4.63 {ImgPhotoCmd procedure: transparency set option} { + p1 transparency set 0 0 false + p1 transparency get 0 0 +} 0 +test imgPhoto-4.64 {ImgPhotoCmd procedure: transparency set option} { + p1 transparency set 0 0 true + p1 transparency get 0 0 +} 1 +# Now for some heftier testing, checking that setting and resetting of +# pixels' transparency status doesn't "leak" with any one-off errors. +proc checkImgTrans {img width height} { + set result {} + for {set x 0} {$x<$width} {incr x} { + for {set y 0} {$y<$height} {incr y} { + if {[$img transparency get $x $y]} { + lappend result $x $y + } + } + } + return $result +} +test imgPhoto-4.65 {ImgPhotoCmd procedure: transparency get option} { + p1 put white -to 0 0 3 3 + checkImgTrans p1 3 3 +} {} +test imgPhoto-4.66 {ImgPhotoCmd procedure: transparency get option} { + p1 blank + checkImgTrans p1 3 3 +} {0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2} +proc checkImgTransLoopSetReset {img width height} { + set result {} + for {set x 0} {$x<$width} {incr x} { + for {set y 0} {$y<$height} {incr y} { + $img put white -to 0 0 3 3 + $img transparency set $x $y 1 + set result [concat $result [checkImgTrans $img $width $height]] + lappend result , + $img transparency set $x $y 0 + set result [concat $result [checkImgTrans $img $width $height]] + lappend result . + } + } + return $result +} +test imgPhoto-4.67 {ImgPhotoCmd procedure: transparency set option} { + checkImgTransLoopSetReset p1 3 3 +} {0 0 , . 0 1 , . 0 2 , . 1 0 , . 1 1 , . 1 2 , . 2 0 , . 2 1 , . 2 2 , .} +proc checkImgTransLoopResetSet {img width height} { + set result {} + for {set x 0} {$x<$width} {incr x} { + for {set y 0} {$y<$height} {incr y} { + $img blank + $img transparency set $x $y 0 + set result [concat $result [checkImgTrans $img $width $height]] + lappend result , + $img transparency set $x $y 1 + set result [concat $result [checkImgTrans $img $width $height]] + lappend result . + } + } + return $result +} +test imgPhoto-4.68 {ImgPhotoCmd procedure: transparency set option} { + checkImgTransLoopResetSet p1 3 3 +} {0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 2 1 0 1 1 1 2 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 1 0 1 1 1 2 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 1 1 2 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 0 1 2 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 0 1 1 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 0 1 1 1 2 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 .} +catch {rename checkImgTrans {}} +catch {rename checkImgTransLoopSetReset {}} +catch {rename checkImgTransLoopResetSet {}} test imgPhoto-5.1 {ImgPhotoGet/Free procedures, shared instances} { eval image delete [image names] |