? doc/man.macros ? unix/tkConfig.sh ? unix/tktest ? unix/wish Index: ChangeLog =================================================================== RCS file: /cvsroot/tktoolkit/tk/ChangeLog,v retrieving revision 1.421 diff -u -r1.421 ChangeLog --- ChangeLog 2002/01/19 00:36:02 1.421 +++ ChangeLog 2002/01/25 17:07:09 @@ -1,3 +1,11 @@ +2002-01-25 Donal K. Fellows + + * 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-18 Mo DeJong * tests/wm.test: Rewrite stackorder tests that Index: doc/photo.n =================================================================== RCS file: /cvsroot/tktoolkit/tk/doc/photo.n,v retrieving revision 1.7 diff -u -r1.7 photo.n --- doc/photo.n 2001/02/13 21:52:45 1.7 +++ doc/photo.n 2002/01/25 17:07:09 @@ -31,7 +31,11 @@ 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 @@ 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 @@ 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 Index: generic/tkImgPhoto.c =================================================================== RCS file: /cvsroot/tktoolkit/tk/generic/tkImgPhoto.c,v retrieving revision 1.26 diff -u -r1.26 tkImgPhoto.c --- generic/tkImgPhoto.c 2002/01/17 05:13:11 1.26 +++ generic/tkImgPhoto.c 2002/01/25 17:07:11 @@ -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. @@ -565,11 +566,12 @@ 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 @@ } 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 @@ 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 @@ 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 @@ 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 @@ * 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 @@ * 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 @@ */ 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 @@ options.subsampleX, options.subsampleY); break; - } - case PHOTO_DATA: { + + case PHOTO_DATA: { char *data; /* @@ -877,7 +882,7 @@ 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 @@ return result; break; } + case PHOTO_GET: { /* * photo get command - first parse and check parameters. @@ -921,7 +927,8 @@ 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 @@ 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 @@ 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 @@ } 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 @@ } 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 @@ } 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 @@ *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 @@ * 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 @@ 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 @@ 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 @@ 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 @@ } 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 @@ } 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. */ + + Tk_ImageChanged(masterPtr->tkMaster, x, y, + (masterPtr->width - x), (masterPtr->height - y), + masterPtr->width, masterPtr->height); + } + break; - 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); + 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); - if (y < masterPtr->height) { + 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 ((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 (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. */ + TkRegion setRegion = TkCreateRegion(); - Tk_ImageChanged(masterPtr->tkMaster, x, y, - (masterPtr->width - x), (masterPtr->height - y), - masterPtr->width, masterPtr->height); + 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 @@ 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 @@ * 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 @@ 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 @@ } } 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 @@ 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 @@ ckfree(data); } return result; - break; - } } + } return TCL_OK; } Index: tests/imgPhoto.test =================================================================== RCS file: /cvsroot/tktoolkit/tk/tests/imgPhoto.test,v retrieving revision 1.8 diff -u -r1.8 imgPhoto.test --- tests/imgPhoto.test 2000/07/05 23:30:07 1.8 +++ tests/imgPhoto.test 2002/01/25 17:07:11 @@ -134,7 +134,7 @@ } {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.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]