summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tkImgListFormat.c1033
-rw-r--r--generic/tkImgPhoto.c625
-rw-r--r--generic/tkInt.decls7
-rw-r--r--generic/tkInt.h1
-rw-r--r--generic/tkIntDecls.h7
-rw-r--r--generic/tkStubInit.c1
-rw-r--r--generic/tkTest.c54
-rw-r--r--generic/tkWindow.c1
8 files changed, 1401 insertions, 328 deletions
diff --git a/generic/tkImgListFormat.c b/generic/tkImgListFormat.c
new file mode 100644
index 0000000..2cf7a61
--- /dev/null
+++ b/generic/tkImgListFormat.c
@@ -0,0 +1,1033 @@
+/*
+ * tkImgListFormat.c --
+ *
+ * Implements the default image data format. I.e. the format used for
+ * [imageName data] and [imageName put] if no other format is specified.
+ *
+ * The default format consits of a list of scan lines (rows) with each
+ * list element being itself a list of pixels (or columns). For details,
+ * see the manpage photo.n
+ *
+ * This image format cannot read/write files, it is meant for string
+ * data only.
+ *
+ *
+ * Copyright (c) 1994 The Australian National University.
+ * Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright (c) 2002-2003 Donal K. Fellows
+ * Copyright (c) 2003 ActiveState Corporation.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * Authors:
+ * Paul Mackerras (paulus@cs.anu.edu.au),
+ * Department of Computer Science,
+ * Australian National University.
+ *
+ * Simon Bachmann (simonbachmann@bluewin.ch)
+ */
+
+#include "tkImgPhoto.h"
+
+/*
+ * Message to generate when an attempt to allocate memory for an image fails.
+ */
+
+#define TK_PHOTO_ALLOC_FAILURE_MESSAGE \
+ "not enough free memory for image buffer"
+
+
+/*
+ * Color name length limit: do not attempt to parse as color strings that are
+ * longer than this limit
+ */
+
+#define TK_PHOTO_MAX_COLOR_CHARS 99
+
+/*
+ * "Names" for the different formats of a color string.
+ */
+
+enum ColorFormatType {
+ COLORFORMAT_TKCOLOR,
+ COLORFORMAT_EMPTYSTRING,
+ COLORFORMAT_LIST,
+ COLORFORMAT_RGB1,
+ COLORFORMAT_RGB2,
+ COLORFORMAT_ARGB1,
+ COLORFORMAT_ARGB2
+};
+
+/*
+ * Names for the color format types above.
+ * Order must match the one in enum ColorFormatType
+ */
+
+static const char *const colorFormatNames[] = {
+ "tkcolor",
+ "emptystring",
+ "list",
+ "rgb-short",
+ "rgb",
+ "argb-short",
+ "argb",
+ NULL
+};
+
+/*
+ * The following data structure is used to return information from
+ * ParseFormatOptions:
+ */
+
+struct FormatOptions {
+ int options; /* Individual bits indicate which options were
+ * specified - see below. */
+ Tcl_Obj *formatName; /* Name specified without an option. */
+ enum ColorFormatType colorFormat;
+ /* The color format type given with the
+ * -colorformat option */
+};
+
+/*
+ * Bit definitions for use with ParseFormatOptions: each bit is set in the
+ * allowedOptions parameter on a call to ParseFormatOptions if that option
+ * is allowed for the current photo image subcommand. On return, the bit is
+ * set in the options field of the FormatOptions structure if that option
+ * was specified.
+ *
+ * OPT_COLORFORMAT: Set if -alpha option allowed/specified.
+ */
+
+#define OPT_COLORFORMAT 1
+
+/*
+ * List of format option names. The order here must match the order of
+ * declarations of the FMT_OPT_* constants above.
+ */
+
+static const char *const formatOptionNames[] = {
+ "-colorformat",
+ NULL
+};
+
+/*
+ * Forward declarations
+ */
+
+static int ParseFormatOptions(Tcl_Interp *interp, int allowedOptions,
+ int objc, Tcl_Obj *const objv[], int *indexPtr,
+ struct FormatOptions *optPtr);
+static Tcl_Obj *GetBadOptMsg(const char *badValue, int allowedOpts);
+static int StringMatchDef(Tcl_Obj *data, Tcl_Obj *formatString,
+ int *widthPtr, int *heightPtr, Tcl_Interp *interp);
+static int StringReadDef(Tcl_Interp *interp, Tcl_Obj *data,
+ Tcl_Obj *formatString, Tk_PhotoHandle imageHandle,
+ int destX, int destY, int width, int height,
+ int srcX, int srcY);
+static int StringWriteDef(Tcl_Interp *interp,
+ Tcl_Obj *formatString,
+ Tk_PhotoImageBlock *blockPtr);
+static int ParseColor(Tcl_Interp *interp, Tcl_Obj *specObj,
+ Display *display, Colormap colormap, unsigned char *redPtr,
+ unsigned char *greenPtr, unsigned char *bluePtr,
+ unsigned char *alphaPtr);
+static int ParseColorAsList(Tcl_Interp *interp, Tcl_Obj *specObj,
+ unsigned char *redPtr, unsigned char *greenPtr,
+ unsigned char *bluePtr, unsigned char *alphaPtr);
+
+/*
+ * The format record for the default image handler
+ */
+
+Tk_PhotoImageFormat tkImgFmtDefault = {
+ "default", /* name */
+ NULL, /* fileMatchProc: format doesn't support file ops */
+ StringMatchDef, /* stringMatchProc */
+ NULL, /* fileReadProc: format doesn't support file read */
+ StringReadDef, /* stringReadProc */
+ NULL, /* fileWriteProc: format doesn't support file write */
+ StringWriteDef /* stringWriteProc */
+};
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ParseFormatOptions --
+ *
+ * Parse the options passed to the image format handler.
+ *
+ * Results:
+ * On success, the structure pointed to by optPtr is filled with the
+ * values passed or with the defaults and TCL_OK returned.
+ * If an error occurs, leaves an error message in interp and returns
+ * TCL_ERROR.
+ *
+ * Side effects:
+ * The value in *indexPtr is updated to the index of the fist
+ * element in argv[] that does not look like an option/value, or to
+ * argc if parsing reached the end of argv[].
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+ParseFormatOptions(
+ Tcl_Interp *interp, /* For error messages */
+ int allowedOptions, /* Bitfield specifying which options are
+ * to be considered allowed */
+ int objc, /* Number of elements in argv[] */
+ Tcl_Obj *const objv[], /* The arguments to parse */
+ int *indexPtr, /* Index giving the first element to
+ * parse. The value is updated to the
+ * index where parsing ended */
+ struct FormatOptions *optPtr) /* Parsed option values are written to
+ * this struct */
+
+{
+ int index, optIndex, typeIndex, first;
+ const char *option;
+
+ first = 1;
+
+ /*
+ * Fill in default values
+ */
+ optPtr->options = 0;
+ optPtr->formatName = NULL;
+ optPtr->colorFormat = COLORFORMAT_RGB2;
+ for (index = *indexPtr; index < objc; *indexPtr = ++index) {
+ int optionExists;
+
+ /*
+ * The first value can be the format handler's name. It goes to
+ * optPtr->name.
+ */
+ option = Tcl_GetString(objv[index]);
+ if (option[0] != '-') {
+ if (first) {
+ optPtr->formatName = objv[index];
+ first = 0;
+ continue;
+ } else {
+ break;
+ }
+ }
+ first = 0;
+
+ /*
+ * Check if option is known and allowed
+ */
+
+ optionExists = 1;
+ if (Tcl_GetIndexFromObj(NULL, objv[index], formatOptionNames,
+ "format option", 0, &optIndex) != TCL_OK) {
+ optionExists = 0;
+ }
+ if (!optionExists || !((1 << optIndex) & allowedOptions)) {
+ Tcl_SetObjResult(interp, GetBadOptMsg(Tcl_GetString(objv[index]),
+ allowedOptions));
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO", "BAD_OPTION", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Option-specific checks
+ */
+
+ switch (1 << optIndex) {
+ case OPT_COLORFORMAT:
+ *indexPtr = ++index;
+ if (Tcl_GetIndexFromObj(NULL, objv[index], colorFormatNames, "",
+ TCL_EXACT, &typeIndex) != TCL_OK
+ || (typeIndex != COLORFORMAT_LIST
+ && typeIndex != COLORFORMAT_RGB2
+ && typeIndex != COLORFORMAT_ARGB2) ) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad color format "
+ "\"%s\": must be rgb, argb, or list",
+ Tcl_GetString(objv[index])));
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO",
+ "BAD_COLOR_FORMAT", NULL);
+ return TCL_ERROR;
+ }
+ optPtr->colorFormat = typeIndex;
+ break;
+ default:
+ Tcl_Panic("ParseFormatOptions: unexpected switch fallthrough");
+ }
+
+ /*
+ * Add option to bitfield in optPtr
+ */
+ optPtr->options |= (1 << optIndex);
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetBadOptMsg --
+ *
+ * Build a Tcl_Obj containing an error message in the form "bad option
+ * "xx": must be y, or z", based on the bits set in allowedOpts.
+ *
+ * Results:
+ * A Tcl Object containig the error message.
+ *
+ * Side effects:
+ * None
+ *----------------------------------------------------------------------
+ */
+static Tcl_Obj *
+GetBadOptMsg(
+ const char *badValue, /* the erroneous option */
+ int allowedOpts) /* bitfield specifying the allowed options */
+{
+ int i, bit;
+ Tcl_Obj *resObj = Tcl_ObjPrintf("bad format option \"%s\": ", badValue);
+
+ if (allowedOpts == 0) {
+ Tcl_AppendToObj(resObj, "no options allowed", -1);
+ } else {
+ Tcl_AppendToObj(resObj, "must be ", -1);
+ bit = 1;
+ for (i = 0; formatOptionNames[i] != NULL; i++) {
+ if (allowedOpts & bit) {
+ if (allowedOpts & (bit -1)) {
+ /*
+ * not the first option
+ */
+ if (allowedOpts & ~((bit << 1) - 1)) {
+ /*
+ * not the last option
+ */
+ Tcl_AppendToObj(resObj, ", ", -1);
+ } else {
+ Tcl_AppendToObj(resObj, ", or ", -1);
+ }
+ }
+ Tcl_AppendToObj(resObj, formatOptionNames[i], -1);
+ }
+ bit <<=1;
+ }
+ }
+ return resObj;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * StringMatchDef --
+ *
+ * Default string match function. Test if image data in string form
+ * appears to be in the default list-of-list-of-pixel-data format
+ * accepted by the "<img> put" command.
+ *
+ * Results:
+ * If thte data is in the default format, writes the size of the image
+ * to widthPtr and heightPtr and returns 1. Otherwise, leaves an error
+ * message in interp (if not NULL) and returns 0.
+ * Note that this function does not parse all data points. A return
+ * value of 1 does not guarantee that the data can be read without
+ * errors.
+ *
+ * Side effects:
+ * None
+ *----------------------------------------------------------------------
+ */
+static int
+StringMatchDef(
+ Tcl_Obj *data, /* The data to check */
+ Tcl_Obj *formatString, /* Value of the -format option, not used here */
+ int *widthPtr, /* Width of image is written to this location */
+ int *heightPtr, /* Height of image is written to this location */
+ Tcl_Interp *interp) /* Error messages are left in this interpreter */
+{
+ int y, rowCount, colCount, curColCount;
+ unsigned char dummy;
+ Tcl_Obj **rowListPtr, *pixelData;
+
+ /*
+ * See if data can be parsed as a list, if every element is itself a valid
+ * list and all sublists have the same length.
+ */
+
+ if (Tcl_ListObjGetElements(interp, data, &rowCount, &rowListPtr)
+ != TCL_OK) {
+ return 0;
+ }
+ if (rowCount == 0) {
+ /*
+ * empty list is valid data
+ */
+
+ *widthPtr = 0;
+ *heightPtr = 0;
+ return 1;
+ }
+ colCount = -1;
+ for (y = 0; y < rowCount; y++) {
+ if (Tcl_ListObjLength(interp, rowListPtr[y], &curColCount) != TCL_OK) {
+ return 0;
+ }
+ if (colCount < 0) {
+ colCount = curColCount;
+ } else if (curColCount != colCount) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("invalid row # %d: "
+ "all rows must have the same number of elements", y));
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO",
+ "INVALID_DATA", NULL);
+ }
+ return 0;
+ }
+ }
+
+ /*
+ * Data in base64 encoding (or even binary data), might actually pass
+ * these tests. To avoid parsing it as list of lists format, check one
+ * pixel for validity.
+ */
+ if (Tcl_ListObjIndex(interp, rowListPtr[0], 0, &pixelData) != TCL_OK) {
+ return 0;
+ }
+ if (Tcl_GetCharLength(pixelData) > TK_PHOTO_MAX_COLOR_CHARS) {
+ return 0;
+ }
+ if (ParseColor(interp, pixelData, Tk_Display(Tk_MainWindow(interp)),
+ Tk_Colormap(Tk_MainWindow(interp)), &dummy, &dummy, &dummy, &dummy)
+ != TCL_OK) {
+ return 0;
+ }
+
+ /*
+ * Looks like we have valid data for this format.
+ * We do not check any pixel values - that's the job of ImgStringRead()
+ */
+
+ *widthPtr = colCount;
+ *heightPtr = rowCount;
+
+ return 1;
+
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * StringReadDef --
+ *
+ * String read function for default format. (see manpage for details on
+ * the format).
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * If the data has valid format, write it to the image identified by
+ * imageHandle.
+ * If the image data cannot be parsed, an error message is left in
+ * interp.
+ *
+ *----------------------------------------------------------------------
+*/
+
+static int
+StringReadDef(
+ Tcl_Interp *interp, /* leave error messages here */
+ Tcl_Obj *data, /* the data to parse */
+ Tcl_Obj *formatString, /* value of the -format option */
+ Tk_PhotoHandle imageHandle, /* write data to this image */
+ int destX, int destY, /* start writing data at this point
+ * in destination image*/
+ int width, int height, /* dimensions of area to write to */
+ int srcX, int srcY) /* start reading source data at these
+ * coordinates */
+{
+ Tcl_Obj **rowListPtr, **colListPtr;
+ Tcl_Obj **objv;
+ int objc;
+ unsigned char *curPixelPtr;
+ int x, y, rowCount, colCount, curColCount;
+ Tk_PhotoImageBlock srcBlock;
+ Display *display;
+ Colormap colormap;
+ struct FormatOptions opts;
+ int optIndex;
+
+ /*
+ * Parse format suboptions
+ * We don't use any format suboptions, but we still need to provide useful
+ * error messages if suboptions were specified.
+ */
+
+ memset(&opts, 0, sizeof(opts));
+ if (formatString != NULL) {
+ if (Tcl_ListObjGetElements(interp, formatString, &objc, &objv)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ optIndex = 0;
+ if (ParseFormatOptions(interp, 0, objc, objv, &optIndex, &opts)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (optIndex < objc) {
+ Tcl_SetObjResult(interp,
+ GetBadOptMsg(Tcl_GetString(objv[optIndex]), 0));
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO", "BAD_OPTION", NULL);
+ return TCL_ERROR;
+ }
+ }
+
+ /*
+ * Check input data
+ */
+
+ if (Tcl_ListObjGetElements(interp, data, &rowCount, &rowListPtr)
+ != TCL_OK ) {
+ return TCL_ERROR;
+ }
+ if ( rowCount > 0 && Tcl_ListObjLength(interp, rowListPtr[0], &colCount)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (width <= 0 || height <= 0 || colCount == 0 || rowCount == 0) {
+ /*
+ * No changes with zero sized input or zero sized output region
+ */
+
+ return TCL_OK;
+ }
+ if (srcX < 0 || srcY < 0 || srcX >= rowCount || srcY >= colCount) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("source coordinates out of range"));
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO", "COORDINATES", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Memory allocation overflow protection.
+ * May not be able to trigger/ demo / test this.
+ */
+
+ if (colCount > (int)(UINT_MAX / 4 / rowCount)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "photo image dimensions exceed Tcl memory limits"));
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO",
+ "OVERFLOW", NULL);
+ return TCL_OK;
+ }
+
+ /*
+ * Read data and put it to imageHandle
+ */
+
+ srcBlock.width = colCount - srcX;
+ srcBlock.height = rowCount - srcY;
+ srcBlock.pixelSize = 4;
+ srcBlock.pitch = srcBlock.width * 4;
+ srcBlock.offset[0] = 0;
+ srcBlock.offset[1] = 1;
+ srcBlock.offset[2] = 2;
+ srcBlock.offset[3] = 3;
+ srcBlock.pixelPtr = attemptckalloc(srcBlock.pitch * srcBlock.height);
+ if (srcBlock.pixelPtr == NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(TK_PHOTO_ALLOC_FAILURE_MESSAGE));
+ Tcl_SetErrorCode(interp, "TK", "MALLOC", NULL);
+ return TCL_ERROR;
+ }
+ curPixelPtr = srcBlock.pixelPtr;
+ display = Tk_Display(Tk_MainWindow(interp));
+ colormap = Tk_Colormap(Tk_MainWindow(interp));
+ for (y = srcY; y < rowCount; y++) {
+ /*
+ * We don't test the length of row, as that's been done in
+ * ImgStringMatch()
+ */
+
+ if (Tcl_ListObjGetElements(interp, rowListPtr[y], &curColCount,
+ &colListPtr) != TCL_OK) {
+ goto errorExit;
+ }
+ for (x = srcX; x < colCount; x++) {
+ if (ParseColor(interp, colListPtr[x], display, colormap,
+ curPixelPtr, curPixelPtr + 1, curPixelPtr + 2,
+ curPixelPtr + 3) != TCL_OK) {
+ goto errorExit;
+ }
+ curPixelPtr += 4;
+ }
+ }
+
+ /*
+ * Write image data to destHandle
+ */
+
+ if (Tk_PhotoPutBlock(interp, imageHandle, &srcBlock, destX, destY,
+ width, height, TK_PHOTO_COMPOSITE_SET) != TCL_OK) {
+ goto errorExit;
+ }
+
+ ckfree(srcBlock.pixelPtr);
+
+ return TCL_OK;
+
+ errorExit:
+ ckfree(srcBlock.pixelPtr);
+
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * StringWriteDef --
+ *
+ * String write function for default image data format. See the user
+ * documentation for details.
+ *
+ * Results:
+ * The converted data is set as the result of interp. Returns a standard
+ * Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+StringWriteDef(
+ Tcl_Interp *interp,
+ Tcl_Obj *formatString,
+ Tk_PhotoImageBlock *blockPtr)
+{
+ int greenOffset, blueOffset, alphaOffset, hasAlpha;
+ Tcl_Obj *data, **objv = NULL;
+ int objc, allowedOpts, optIndex;
+ struct FormatOptions opts;
+
+ /*
+ * Parse format suboptions
+ */
+ if (Tcl_ListObjGetElements(interp, formatString, &objc, &objv)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ allowedOpts = OPT_COLORFORMAT;
+ optIndex = 0;
+ if (ParseFormatOptions(interp, allowedOpts, objc, objv, &optIndex, &opts)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (optIndex < objc) {
+ Tcl_SetObjResult(interp,
+ GetBadOptMsg(Tcl_GetString(objv[optIndex]), allowedOpts));
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO", "BAD_OPTION", NULL);
+ return TCL_ERROR;
+ }
+
+ greenOffset = blockPtr->offset[1] - blockPtr->offset[0];
+ blueOffset = blockPtr->offset[2] - blockPtr->offset[0];
+
+ /*
+ * A negative alpha offset signals that the image is fully opaque.
+ * That's not really documented anywhere, but it's the way it is!
+ */
+
+ if (blockPtr->offset[3] < 0) {
+ hasAlpha = 0;
+ } else {
+ hasAlpha = 1;
+ }
+ alphaOffset = blockPtr->offset[3] - blockPtr->offset[0];
+
+ data = Tcl_NewObj();
+ if ((blockPtr->width > 0) && (blockPtr->height > 0)) {
+ int row, col;
+ Tcl_Obj *line, *colorList[4];
+ unsigned char *pixelPtr;
+ unsigned char alphaVal = 255;
+
+ for (row=0; row<blockPtr->height; row++) {
+ line = Tcl_NewObj();
+ pixelPtr = blockPtr->pixelPtr + blockPtr->offset[0]
+ + row * blockPtr->pitch;
+
+ for (col=0; col<blockPtr->width; col++) {
+ if (hasAlpha) {
+ alphaVal = pixelPtr[alphaOffset];
+ }
+
+ /*
+ * We don't build lines as a list for #ARGB and #RGB. Since
+ * these color formats look like comments, the first element
+ * of the list would get quoted with an additional {} .
+ * While this is would not be a problem if the data is used as
+ * a list, it will cause problems if someone decides to parse
+ * it as a string.
+ */
+
+ switch (opts.colorFormat) {
+ case COLORFORMAT_RGB2:
+ Tcl_AppendPrintfToObj(line, "%s#%02x%02x%02x",
+ col == 0 ? "" : " ", pixelPtr[0],
+ pixelPtr[greenOffset], pixelPtr[blueOffset]);
+ break;
+ case COLORFORMAT_ARGB2:
+ Tcl_AppendPrintfToObj(line, "%s#%02x%02x%02x%02x",
+ col == 0 ? "" : " ", alphaVal, pixelPtr[0],
+ pixelPtr[greenOffset], pixelPtr[blueOffset]);
+ break;
+ case COLORFORMAT_LIST:
+ colorList[0] = Tcl_NewIntObj(pixelPtr[0]);
+ colorList[1] = Tcl_NewIntObj(pixelPtr[greenOffset]);
+ colorList[2] = Tcl_NewIntObj(pixelPtr[blueOffset]);
+ colorList[3] = Tcl_NewIntObj(alphaVal);
+ if (Tcl_ListObjAppendElement(interp, line,
+ Tcl_NewListObj(4, colorList)) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ break;
+ default:
+ Tcl_Panic("unexpected switch fallthrough");
+ }
+ pixelPtr += blockPtr->pixelSize;
+ }
+ if (Tcl_ListObjAppendElement(interp, data, line) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+ }
+ Tcl_SetObjResult(interp, data);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ParseColor --
+ *
+ * This function extracts color and alpha values from a string. It
+ * understands standard Tk color formats, alpha suffixes and the color
+ * formats specific to photo images, which include alpha data.
+ *
+ * Results:
+ * On success, writes red, green, blue and alpha values to the
+ * corresponding pointers. If the color spec contains no alpha
+ * information, 255 is taken as transparency value.
+ * If the input cannot be parsed, leaves an error message in
+ * interp. Returns a standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+ParseColor(
+ Tcl_Interp *interp, /* error messages go there */
+ Tcl_Obj *specObj, /* the color data to parse */
+ Display *display, /* display of main window, needed to parse
+ * standard Tk colors */
+ Colormap colormap, /* colormap of current display */
+ unsigned char *redPtr, /* the result is written to these pointers */
+ unsigned char *greenPtr,
+ unsigned char *bluePtr,
+ unsigned char *alphaPtr)
+{
+ const char *specString, *suffixString, *colorString;
+ Tcl_Obj *colorObj = NULL;
+ unsigned int i, charCount;
+ XColor parsedColor;
+ int parsedAsList;
+
+ /*
+ * If the string representation of color data is invalid, try to parse it
+ * as a list first, in order to avoid shimmering.
+ */
+
+ parsedAsList = 0;
+ if (specObj->bytes == NULL) {
+ if (ParseColorAsList(interp, specObj, redPtr, greenPtr, bluePtr,
+ alphaPtr) == TCL_OK) {
+ goto okExit;
+ } else {
+ Tcl_ResetResult(interp);
+ }
+ parsedAsList = 1;
+ }
+
+ /*
+ * Next, try the formats that have no suffix
+ */
+ specString = Tcl_GetString(specObj);
+ if (strlen(specString) == 0) {
+ /* Empty string */
+ *redPtr = *greenPtr = *bluePtr = *alphaPtr = 0;
+ goto okExit;
+ }
+
+ charCount = strlen(specString);
+ if (specString[0] == '#'
+ && (charCount - 1 == 4 || charCount - 1 == 8)) {
+ int hexDigitsOnly = 1;
+ for (i = 1; i < charCount; i++) {
+ if ( ! isxdigit(UCHAR(specString[i]))) {
+ hexDigitsOnly = 0;
+ break;
+ }
+ }
+
+ if (hexDigitsOnly) {
+ switch (charCount - 1) {
+ case 4:
+ /* #ARGB format */
+ sscanf(specString, "#%1hhx%1hhx%1hhx%1hhx", alphaPtr,
+ redPtr, greenPtr, bluePtr);
+ *redPtr *= 0x11;
+ *greenPtr *= 0x11;
+ *bluePtr *= 0x11;
+ *alphaPtr *= 0x11;
+ goto okExit;
+ break;
+ case 8:
+ /* #AARRGGBB format */
+ sscanf(specString, "#%2hhx%2hhx%2hhx%2hhx", alphaPtr, redPtr,
+ greenPtr, bluePtr);
+ goto okExit;
+ break;
+ default:
+ Tcl_Panic("unexpected switch fallthrough");
+ }
+ }
+ }
+
+ /*
+ * Split color data string in color and suffix parts
+ */
+
+ if ((suffixString = strrchr(specString, '@')) == NULL
+ && ((suffixString = strrchr(specString, '#')) == NULL
+ || suffixString == specString)) {
+ suffixString = specString + strlen(specString);
+ colorString = specString;
+ colorObj = specObj;
+ } else {
+ colorObj = Tcl_NewStringObj(specString, suffixString - specString);
+ colorString = Tcl_GetString(colorObj);
+ }
+
+ /*
+ * Try to parse as standard Tk color.
+ *
+ * We don't use Tk_GetColor() et al. here, as those functions
+ * migth return a color that does not exaxtly match the given name
+ * if the colormap is full. Also, we don't really want the color to be
+ * added to the colormap.
+ */
+
+ if (TkParseColor(display, colormap, colorString, &parsedColor)) {
+ char *tmpString;
+ double fracAlpha;
+ unsigned int suffixAlpha;
+
+ parsedColor.red >>= 8;
+ parsedColor.green >>= 8;
+ parsedColor.blue >>= 8;
+
+ /*
+ * parse the Suffix
+ */
+
+ switch (suffixString[0]) {
+ case '\0':
+ suffixAlpha = 255;
+ break;
+ case '@':
+ fracAlpha = strtod(suffixString + 1, &tmpString);
+ if (*tmpString != '\0') {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("invalid alpha "
+ "suffix \"%s\": expected floating-point value",
+ suffixString));
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO",
+ "INVALID COLOR", NULL);
+ goto errorExit;
+ }
+ if (fracAlpha < 0 || fracAlpha > 1) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("invalid alpha suffix"
+ " \"%s\": value must be in the range from 0 to 1",
+ suffixString));
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO",
+ "INVALID_COLOR", NULL);
+ goto errorExit;
+ }
+ suffixAlpha = round(fracAlpha * 255);
+ break;
+ case '#':
+ if (strlen(suffixString + 1) < 1 || strlen(suffixString + 1)> 2) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid alpha suffix \"%s\"", suffixString));
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO",
+ "INVALID_COLOR", NULL);
+ goto errorExit;
+ }
+ for (i = 1; i <= strlen(suffixString + 1); i++) {
+ if ( ! isxdigit(UCHAR(suffixString[i]))) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid alpha suffix \"%s\": expected hex digit",
+ suffixString));
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO",
+ "INVALID_COLOR", NULL);
+ goto errorExit;
+ }
+ }
+ if (strlen(suffixString + 1) == 1) {
+ sscanf(suffixString, "#%1x", &suffixAlpha);
+ suffixAlpha *= 0x11;
+ } else {
+ sscanf(suffixString, "#%2x", &suffixAlpha);
+ }
+ break;
+ default:
+ Tcl_Panic("unexpected switch fallthrough");
+ }
+ *redPtr = parsedColor.red;
+ *greenPtr = parsedColor.green;
+ *bluePtr = parsedColor.blue;
+ *alphaPtr = suffixAlpha;
+
+ goto okExit;
+ }
+
+ /*
+ * Last, try to parse as a list, if we didn't already.
+ */
+ if ( !parsedAsList && ParseColorAsList(interp, specObj, redPtr, greenPtr,
+ bluePtr, alphaPtr) == TCL_OK) {
+ goto okExit;
+ }
+ Tcl_ResetResult(interp);
+
+ /*
+ * Looks like we can't figure it out and must give up...
+ */
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid color name \"%s\"", specString));
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO",
+ "INVALID_COLOR", NULL);
+ goto errorExit;
+
+ okExit:
+ if (colorObj != NULL && colorObj != specObj) {
+ Tcl_DecrRefCount(colorObj);
+ }
+
+ return TCL_OK;
+
+ errorExit:
+ if (colorObj != NULL && colorObj != specObj) {
+ Tcl_DecrRefCount(colorObj);
+ }
+
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ParseColorAsList --
+ *
+ * This function extracts color and alpha values from a list of 3 or 4
+ * integers (the list color format).
+ *
+ * Results:
+ * On success, writes red, green, blue and alpha values to the
+ * corresponding pointers. If the color spec contains no alpha
+ * information, 255 is taken as transparency value.
+ * If the input cannot be parsed, leaves an error message in
+ * interp. Returns a standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+ParseColorAsList(
+ Tcl_Interp *interp, /* error messages go there */
+ Tcl_Obj *specObj, /* the color data to parse */
+ unsigned char *redPtr, /* the result is written to these pointers */
+ unsigned char *greenPtr,
+ unsigned char *bluePtr,
+ unsigned char *alphaPtr)
+{
+ int listLen;
+ unsigned int i;
+ int values[4];
+ Tcl_Obj *curValue;
+ const char *specString;
+
+
+ if (Tcl_ListObjLength(interp, specObj, &listLen) != TCL_OK
+ || listLen < 3 || listLen > 4) {
+ specString = Tcl_GetString(specObj);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("invalid color name \"%s\"",
+ specString));
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO",
+ "INVALID_COLOR", NULL);
+ return TCL_ERROR;
+ }
+ values[3] = -1;
+ for (i = 0; i < (unsigned)listLen; i++) {
+ if (Tcl_ListObjIndex(interp, specObj, i, &curValue) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIntFromObj(interp, curValue, values + i) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (values[i] < 0 || values[i] > 255) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("invalid color: "
+ "expected integers in the range from 0 to 255"));
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO",
+ "INVALID_COLOR", NULL);
+ return TCL_ERROR;
+ }
+ }
+ *redPtr = values[0];
+ *greenPtr = values[1];
+ *bluePtr = values[2];
+ *alphaPtr = values[3] == -1 ? 255 : values[3];
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TkDebugStringMatchDef --
+ *
+ * Debugging function for StringMatchDef. Basically just an alias for
+ * that function, intended to expose it directly to tests, as
+ * StirngMatchDef cannot be sufficiently tested otherwise.
+ *
+ * Results:
+ * See StringMatchDef.
+ *
+ * Side effects:
+ * None
+ *----------------------------------------------------------------------
+ */
+int
+TkDebugPhotoStringMatchDef(
+ Tcl_Interp *interp, /* Error messages are left in this interpreter */
+ Tcl_Obj *data, /* The data to check */
+ Tcl_Obj *formatString, /* Value of the -format option, not used here */
+ int *widthPtr, /* Width of image is written to this location */
+ int *heightPtr) /* Height of image is written to this location */
+{
+ return StringMatchDef(data, formatString, widthPtr, heightPtr, interp);
+}
+
diff --git a/generic/tkImgPhoto.c b/generic/tkImgPhoto.c
index 1bd0142..d6097e0 100644
--- a/generic/tkImgPhoto.c
+++ b/generic/tkImgPhoto.c
@@ -48,7 +48,9 @@ struct SubcommandOptions {
* set in the options field of the SubcommandOptions structure if that option
* was specified.
*
+ * OPT_ALPHA: Set if -alpha option allowed/specified.
* OPT_BACKGROUND: Set if -format option allowed/specified.
+ * OPT_BOOLEAN: Set if -boolean option allowed/specified.
* OPT_COMPOSITE: Set if -compositingrule option allowed/spec'd.
* OPT_FORMAT: Set if -format option allowed/specified.
* OPT_FROM: Set if -from option allowed/specified.
@@ -56,18 +58,22 @@ struct SubcommandOptions {
* OPT_SHRINK: Set if -shrink option allowed/specified.
* OPT_SUBSAMPLE: Set if -subsample option allowed/spec'd.
* OPT_TO: Set if -to option allowed/specified.
+ * OPT_WITHALPHA: Set if -withalpha option allowed/specified.
* OPT_ZOOM: Set if -zoom option allowed/specified.
*/
-#define OPT_BACKGROUND 1
-#define OPT_COMPOSITE 2
-#define OPT_FORMAT 4
-#define OPT_FROM 8
-#define OPT_GRAYSCALE 0x10
-#define OPT_SHRINK 0x20
-#define OPT_SUBSAMPLE 0x40
-#define OPT_TO 0x80
-#define OPT_ZOOM 0x100
+#define OPT_ALPHA 1
+#define OPT_BACKGROUND 2
+#define OPT_BOOLEAN 4
+#define OPT_COMPOSITE 8
+#define OPT_FORMAT 0x10
+#define OPT_FROM 0x20
+#define OPT_GRAYSCALE 0x40
+#define OPT_SHRINK 0x80
+#define OPT_SUBSAMPLE 0x100
+#define OPT_TO 0x200
+#define OPT_WITHALPHA 0x400
+#define OPT_ZOOM 0x800
/*
* List of option names. The order here must match the order of declarations
@@ -75,7 +81,9 @@ struct SubcommandOptions {
*/
static const char *const optionNames[] = {
+ "-alpha",
"-background",
+ "-boolean",
"-compositingrule",
"-format",
"-from",
@@ -83,6 +91,7 @@ static const char *const optionNames[] = {
"-shrink",
"-subsample",
"-to",
+ "-withalpha",
"-zoom",
NULL
};
@@ -182,9 +191,6 @@ static int ImgPhotoConfigureMaster(Tcl_Interp *interp,
static int ToggleComplexAlphaIfNeeded(PhotoMaster *mPtr);
static int ImgPhotoSetSize(PhotoMaster *masterPtr, int width,
int height);
-static int ImgStringWrite(Tcl_Interp *interp,
- Tcl_Obj *formatString,
- Tk_PhotoImageBlock *blockPtr);
static char * ImgGetPhoto(PhotoMaster *masterPtr,
Tk_PhotoImageBlock *blockPtr,
struct SubcommandOptions *optPtr);
@@ -402,12 +408,10 @@ ImgPhotoCmd(
};
PhotoMaster *masterPtr = clientData;
- int result, index, x, y, width, height, dataWidth, dataHeight, listObjc;
+ int result, index, x, y, width, height;
struct SubcommandOptions options;
- Tcl_Obj **listObjv, **srcObjv;
unsigned char *pixelPtr;
Tk_PhotoImageBlock block;
- Tk_Window tkwin;
Tk_PhotoImageFormat *imageFormat;
size_t length;
int imageWidth, imageHeight, matched, oldformat = 0;
@@ -653,7 +657,8 @@ ImgPhotoCmd(
options.compositingRule);
case PHOTO_DATA: {
- char *data;
+ char *data = NULL;
+ Tcl_Obj *freeObj = NULL;
/*
* photo data command - first parse and check any options given.
@@ -661,7 +666,7 @@ ImgPhotoCmd(
Tk_ImageStringWriteProc *stringWriteProc = NULL;
- index = 2;
+ index = 1;
memset(&options, 0, sizeof(options));
options.name = NULL;
options.format = NULL;
@@ -672,7 +677,7 @@ ImgPhotoCmd(
&index, objc, objv) != TCL_OK) {
return TCL_ERROR;
}
- if ((options.name != NULL) || (index < objc)) {
+ if ((options.name == NULL) || (index < objc)) {
Tcl_WrongNumArgs(interp, 2, objv, "?-option value ...?");
return TCL_ERROR;
}
@@ -694,50 +699,50 @@ ImgPhotoCmd(
options.fromX2 = masterPtr->width;
options.fromY2 = masterPtr->height;
}
+ if (!(options.options & OPT_FORMAT)) {
+ options.format = Tcl_NewStringObj("default", -1);
+ freeObj = options.format;
+ }
/*
* Search for an appropriate image string format handler.
*/
- if (options.options & OPT_FORMAT) {
- matched = 0;
- for (imageFormat = tsdPtr->formatList; imageFormat != NULL;
- imageFormat = imageFormat->nextPtr) {
- if ((strncasecmp(Tcl_GetString(options.format),
- imageFormat->name, strlen(imageFormat->name)) == 0)) {
- matched = 1;
- if (imageFormat->stringWriteProc != NULL) {
- stringWriteProc = imageFormat->stringWriteProc;
- break;
- }
- }
- }
- if (stringWriteProc == NULL) {
- oldformat = 1;
- for (imageFormat = tsdPtr->oldFormatList; imageFormat != NULL;
- imageFormat = imageFormat->nextPtr) {
- if ((strncasecmp(Tcl_GetString(options.format),
- imageFormat->name,
- strlen(imageFormat->name)) == 0)) {
- matched = 1;
- if (imageFormat->stringWriteProc != NULL) {
- stringWriteProc = imageFormat->stringWriteProc;
- break;
- }
- }
- }
- }
- if (stringWriteProc == NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "image string format \"%s\" is %s",
- Tcl_GetString(options.format),
- (matched ? "not supported" : "unknown")));
- Tcl_SetErrorCode(interp, "TK", "LOOKUP", "PHOTO_FORMAT",
- Tcl_GetString(options.format), NULL);
- return TCL_ERROR;
+ matched = 0;
+ for (imageFormat = tsdPtr->formatList; imageFormat != NULL;
+ imageFormat = imageFormat->nextPtr) {
+ if ((strncasecmp(Tcl_GetString(options.format),
+ imageFormat->name, strlen(imageFormat->name)) == 0)) {
+ matched = 1;
+ if (imageFormat->stringWriteProc != NULL) {
+ stringWriteProc = imageFormat->stringWriteProc;
+ break;
+ }
}
- } else {
- stringWriteProc = ImgStringWrite;
+ }
+ if (stringWriteProc == NULL) {
+ oldformat = 1;
+ for (imageFormat = tsdPtr->oldFormatList; imageFormat != NULL;
+ imageFormat = imageFormat->nextPtr) {
+ if ((strncasecmp(Tcl_GetString(options.format),
+ imageFormat->name,
+ strlen(imageFormat->name)) == 0)) {
+ matched = 1;
+ if (imageFormat->stringWriteProc != NULL) {
+ stringWriteProc = imageFormat->stringWriteProc;
+ break;
+ }
+ }
+ }
+ }
+ if (stringWriteProc == NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "image string format \"%s\" is %s",
+ Tcl_GetString(options.format),
+ (matched ? "not supported" : "unknown")));
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "PHOTO_FORMAT",
+ Tcl_GetString(options.format), NULL);
+ goto dataErrorExit;
}
/*
@@ -774,7 +779,22 @@ ImgPhotoCmd(
if (data) {
ckfree(data);
}
+ if (freeObj != NULL) {
+ Tcl_DecrRefCount(freeObj);
+ }
return result;
+
+ dataErrorExit:
+ if (options.background) {
+ Tk_FreeColor(options.background);
+ }
+ if (data) {
+ ckfree(data);
+ }
+ if (freeObj != NULL) {
+ Tcl_DecrRefCount(freeObj);
+ }
+ return TCL_ERROR;
}
case PHOTO_GET: {
@@ -782,12 +802,24 @@ ImgPhotoCmd(
* photo get command - first parse and check parameters.
*/
- Tcl_Obj *channels[3];
-
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "x y");
+ Tcl_Obj *channels[4];
+ int channelCount = 3;
+
+ index = 3;
+ memset(&options, 0, sizeof(options));
+ options.name = NULL;
+ if (ParseSubcommandOptions(&options, interp, OPT_WITHALPHA,
+ &index, objc, objv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (options.name == NULL || index < objc) {
+ Tcl_WrongNumArgs(interp, 2, objv, "x y ?-withalpha?");
return TCL_ERROR;
}
+ if (options.options & OPT_WITHALPHA) {
+ channelCount = 4;
+ }
+
if ((Tcl_GetIntFromObj(interp, objv[2], &x) != TCL_OK)
|| (Tcl_GetIntFromObj(interp, objv[3], &y) != TCL_OK)) {
return TCL_ERROR;
@@ -803,25 +835,29 @@ ImgPhotoCmd(
}
/*
- * Extract the value of the desired pixel and format it as a string.
+ * Extract the value of the desired pixel and format it as a list.
*/
pixelPtr = masterPtr->pix32 + (y * masterPtr->width + x) * 4;
channels[0] = Tcl_NewIntObj(pixelPtr[0]);
channels[1] = Tcl_NewIntObj(pixelPtr[1]);
channels[2] = Tcl_NewIntObj(pixelPtr[2]);
- Tcl_SetObjResult(interp, Tcl_NewListObj(3, channels));
+ channels[3] = Tcl_NewIntObj(pixelPtr[3]);
+ Tcl_SetObjResult(interp, Tcl_NewListObj(channelCount, channels));
return TCL_OK;
}
- case PHOTO_PUT:
+ case PHOTO_PUT: {
+ Tcl_Obj *format, *data;
+
/*
- * photo put command - first parse the options and colors specified.
+ * photo put command - first parse the options.
*/
index = 2;
memset(&options, 0, sizeof(options));
options.name = NULL;
+ options.format = NULL;
if (ParseSubcommandOptions(&options, interp, OPT_TO|OPT_FORMAT,
&index, objc, objv) != TCL_OK) {
return TCL_ERROR;
@@ -831,174 +867,50 @@ ImgPhotoCmd(
return TCL_ERROR;
}
- if (MatchStringFormat(interp, options.name ? objv[2]:NULL,
- options.format, &imageFormat, &imageWidth,
- &imageHeight, &oldformat) == TCL_OK) {
- Tcl_Obj *format, *data;
-
- if (!(options.options & OPT_TO) || (options.toX2 < 0)) {
- options.toX2 = options.toX + imageWidth;
- options.toY2 = options.toY + imageHeight;
- }
- if (imageWidth > options.toX2 - options.toX) {
- imageWidth = options.toX2 - options.toX;
- }
- if (imageHeight > options.toY2 - options.toY) {
- imageHeight = options.toY2 - options.toY;
- }
- format = options.format;
- data = objv[2];
- if (oldformat) {
- if (format) {
- format = (Tcl_Obj *) Tcl_GetString(format);
- }
- data = (Tcl_Obj *) Tcl_GetString(data);
- }
- if (imageFormat->stringReadProc(interp, data, format,
- (Tk_PhotoHandle) masterPtr, options.toX, options.toY,
- imageWidth, imageHeight, 0, 0) != TCL_OK) {
- return TCL_ERROR;
- }
- masterPtr->flags |= IMAGE_CHANGED;
- return TCL_OK;
- }
- if (options.options & OPT_FORMAT) {
- return TCL_ERROR;
- }
- Tcl_ResetResult(interp);
- if (Tcl_ListObjGetElements(interp, options.name,
- &dataHeight, &srcObjv) != TCL_OK) {
+ /*
+ * See if there's a format that can read the data
+ */
+
+ if (MatchStringFormat(interp, objv[2], options.format, &imageFormat,
+ &imageWidth, &imageHeight, &oldformat) != TCL_OK) {
return TCL_ERROR;
}
- tkwin = Tk_MainWindow(interp);
- block.pixelPtr = NULL;
- dataWidth = 0;
- pixelPtr = NULL;
- for (y = 0; y < dataHeight; ++y) {
- if (Tcl_ListObjGetElements(interp, srcObjv[y],
- &listObjc, &listObjv) != TCL_OK) {
- break;
- }
- if (y == 0) {
- if (listObjc == 0) {
- /*
- * Lines must be non-empty...
- */
-
- break;
- }
- dataWidth = listObjc;
- /*
- * Memory allocation overflow protection.
- * May not be able to trigger/ demo / test this.
- */
-
- if (dataWidth > (int)((UINT_MAX/3) / dataHeight)) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "photo image dimensions exceed Tcl memory limits", -1));
- Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO",
- "OVERFLOW", NULL);
- break;
- }
-
- pixelPtr = ckalloc(dataWidth * dataHeight * 3);
- block.pixelPtr = pixelPtr;
- } else if (listObjc != dataWidth) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "all elements of color list must have the same"
- " number of elements", -1));
- Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO",
- "NON_RECTANGULAR", NULL);
- break;
- }
-
- for (x = 0; x < dataWidth; ++x) {
- const char *colorString = Tcl_GetString(listObjv[x]);
- XColor color;
- int tmpr, tmpg, tmpb;
-
- /*
- * We do not use Tk_GetColorFromObj() because we absolutely do
- * not want to invoke the fallback code.
- */
-
- if (colorString[0] == '#') {
- if (isxdigit(UCHAR(colorString[1])) &&
- isxdigit(UCHAR(colorString[2])) &&
- isxdigit(UCHAR(colorString[3]))) {
- if (colorString[4] == '\0') {
- /* Got #rgb */
- sscanf(colorString+1, "%1x%1x%1x",
- &tmpr, &tmpg, &tmpb);
- *pixelPtr++ = tmpr * 0x11;
- *pixelPtr++ = tmpg * 0x11;
- *pixelPtr++ = tmpb * 0x11;
- continue;
- } else if (isxdigit(UCHAR(colorString[4])) &&
- isxdigit(UCHAR(colorString[5])) &&
- isxdigit(UCHAR(colorString[6])) &&
- colorString[7] == '\0') {
- /* Got #rrggbb */
- sscanf(colorString+1, "%2x%2x%2x",
- &tmpr, &tmpg, &tmpb);
- *pixelPtr++ = tmpr;
- *pixelPtr++ = tmpg;
- *pixelPtr++ = tmpb;
- continue;
- }
- }
- }
-
- if (!TkParseColor(Tk_Display(tkwin), Tk_Colormap(tkwin),
- colorString, &color)) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "can't parse color \"%s\"", colorString));
- Tcl_SetErrorCode(interp, "TK", "VALUE", "COLOR", NULL);
- break;
- }
- *pixelPtr++ = color.red >> 8;
- *pixelPtr++ = color.green >> 8;
- *pixelPtr++ = color.blue >> 8;
- }
- if (x < dataWidth) {
- break;
- }
+ if (!(options.options & OPT_TO) || (options.toX2 < 0)) {
+ options.toX2 = options.toX + imageWidth;
+ options.toY2 = options.toY + imageHeight;
}
- if (y < dataHeight || dataHeight == 0 || dataWidth == 0) {
- if (block.pixelPtr != NULL) {
- ckfree(block.pixelPtr);
- }
- if (y < dataHeight) {
- return TCL_ERROR;
+ if (imageWidth > options.toX2 - options.toX) {
+ imageWidth = options.toX2 - options.toX;
+ }
+ if (imageHeight > options.toY2 - options.toY) {
+ imageHeight = options.toY2 - options.toY;
+ }
+ format = options.format;
+ data = objv[2];
+ if (oldformat) {
+ if (format) {
+ format = (Tcl_Obj *) Tcl_GetString(format);
}
- return TCL_OK;
+ data = (Tcl_Obj *) Tcl_GetString(data);
}
+ if (imageFormat->stringReadProc(interp, data, format,
+ (Tk_PhotoHandle) masterPtr, options.toX, options.toY,
+ options.toX2 - options.toX,
+ options.toY2 - options.toY, 0, 0) != TCL_OK) {
+ return TCL_ERROR;
+ }
/*
- * Fill in default values for the -to option, then copy the block in
- * using Tk_PhotoPutBlock.
+ * SB: is the next line really needed? The stringReadProc
+ * writes image data with Tk_PhotoPutBlock(), which in turn
+ * takes care to notify the changed image and to set/unset the
+ * IMAGE_CHANGED bit.
*/
-
- if (!(options.options & OPT_TO) || (options.toX2 < 0)) {
- options.toX2 = options.toX + dataWidth;
- options.toY2 = options.toY + dataHeight;
- }
- block.width = dataWidth;
- block.height = dataHeight;
- block.pitch = dataWidth * 3;
- block.pixelSize = 3;
- block.offset[0] = 0;
- block.offset[1] = 1;
- block.offset[2] = 2;
- block.offset[3] = 0;
- result = Tk_PhotoPutBlock(interp, masterPtr, &block,
- options.toX, options.toY, options.toX2 - options.toX,
- options.toY2 - options.toY,
- TK_PHOTO_COMPOSITE_SET);
- ckfree(block.pixelPtr);
- return result;
-
+ masterPtr->flags |= IMAGE_CHANGED;
+
+ return TCL_OK;
+ }
case PHOTO_READ: {
Tcl_Obj *format;
@@ -1168,17 +1080,40 @@ ImgPhotoCmd(
switch ((enum transOptions) index) {
case PHOTO_TRANS_GET: {
- XRectangle testBox;
- TkRegion testRegion;
+ int boolMode;
- if (objc != 5) {
- Tcl_WrongNumArgs(interp, 3, objv, "x y");
+ /*
+ * parse fixed args and option
+ */
+
+ if (objc > 6 || objc < 5) {
+ Tcl_WrongNumArgs(interp, 3, objv, "x y ?-option?");
return TCL_ERROR;
}
if ((Tcl_GetIntFromObj(interp, objv[3], &x) != TCL_OK)
|| (Tcl_GetIntFromObj(interp, objv[4], &y) != TCL_OK)) {
return TCL_ERROR;
}
+
+ index = 4;
+ memset(&options, 0, sizeof(options));
+ if (ParseSubcommandOptions(&options, interp,
+ OPT_ALPHA | OPT_BOOLEAN, &index, objc, objv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (index < objc) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown option \"%s\": must be -alpha, or -boolean",
+ Tcl_GetString(objv[index])));
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO", "BAD_OPTION",
+ NULL);
+ return TCL_ERROR;
+ }
+ boolMode = 1;
+ if (options.options & OPT_ALPHA) {
+ boolMode = 0;
+ }
+
if ((x < 0) || (x >= masterPtr->width)
|| (y < 0) || (y >= masterPtr->height)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -1189,36 +1124,56 @@ ImgPhotoCmd(
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_SetObjResult(interp, Tcl_NewBooleanObj(
- testBox.width==0 && testBox.height==0));
+ /*
+ * Extract and return the desired value
+ */
+ pixelPtr = masterPtr->pix32 + (y * masterPtr->width + x) * 4;
+ if (boolMode) {
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj( ! pixelPtr[3]));
+ } else {
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(pixelPtr[3]));
+ }
return TCL_OK;
}
case PHOTO_TRANS_SET: {
- int transFlag;
+ int newVal, boolMode;
+ //const char *arg;
XRectangle setBox;
+ TkRegion modRegion;
- if (objc != 6) {
- Tcl_WrongNumArgs(interp, 3, objv, "x y boolean");
+ /*
+ * Parse args and option, check for valid values
+ */
+
+ if (objc < 6 || objc > 7) {
+ Tcl_WrongNumArgs(interp, 3, objv, "x y newVal ?-option?");
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)) {
+ || (Tcl_GetIntFromObj(interp, objv[4], &y) != TCL_OK)) {
return TCL_ERROR;
}
+
+ index = 5;
+ memset(&options, 0, sizeof(options));
+ if (ParseSubcommandOptions(&options, interp,
+ OPT_ALPHA | OPT_BOOLEAN, &index, objc, objv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (index < objc) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown option \"%s\": must be -alpha, or -boolean",
+ Tcl_GetString(objv[index])));
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO", "BAD_OPTION",
+ NULL);
+ return TCL_ERROR;
+ }
+ boolMode = 1;
+ if (options.options & OPT_ALPHA) {
+ boolMode = 0;
+ }
+
if ((x < 0) || (x >= masterPtr->width)
|| (y < 0) || (y >= masterPtr->height)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -1229,38 +1184,53 @@ ImgPhotoCmd(
return TCL_ERROR;
}
+ if (boolMode) {
+ if (Tcl_GetBooleanFromObj(interp, objv[5], &newVal) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ } else {
+ if (Tcl_GetIntFromObj(interp, objv[5], &newVal) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (newVal < 0 || newVal > 255) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid alpha value \"%d\": "
+ "must be integer between 0 and 255", newVal));
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO",
+ "BAD_VALUE", NULL);
+ return TCL_ERROR;
+ }
+ }
+
+ /*
+ * Set new alpha value for the pixel
+ */
+
+ pixelPtr = masterPtr->pix32 + (y * masterPtr->width + x) * 4;
+ if (boolMode) {
+ pixelPtr[3] = newVal ? 0 : 255;
+ } else {
+ pixelPtr[3] = newVal;
+ }
+
+ /*
+ * Update the validRegion of the image
+ */
+
setBox.x = x;
setBox.y = y;
setBox.width = 1;
setBox.height = 1;
- pixelPtr = masterPtr->pix32 + (y * masterPtr->width + x) * 4;
-
- if (transFlag) {
- /*
- * Make pixel transparent.
- */
-
- TkRegion clearRegion = TkCreateRegion();
-
- TkUnionRectWithRegion(&setBox, clearRegion, clearRegion);
- TkSubtractRegion(masterPtr->validRegion, clearRegion,
+ modRegion = TkCreateRegion();
+ TkUnionRectWithRegion(&setBox, modRegion, modRegion);
+ if (pixelPtr[3]) {
+ TkUnionRectWithRegion(&setBox, masterPtr->validRegion,
masterPtr->validRegion);
- TkDestroyRegion(clearRegion);
-
- /*
- * Set the alpha value correctly.
- */
-
- pixelPtr[3] = 0;
} else {
- /*
- * Make pixel opaque.
- */
-
- TkUnionRectWithRegion(&setBox, masterPtr->validRegion,
+ TkSubtractRegion(masterPtr->validRegion, modRegion,
masterPtr->validRegion);
- pixelPtr[3] = 255;
}
+ TkDestroyRegion(modRegion);
/*
* Inform the generic image code that the image
@@ -1462,13 +1432,18 @@ GetExtension(
*
* This function is invoked to process one of the options which may be
* specified for the photo image subcommands, namely, -from, -to, -zoom,
- * -subsample, -format, -shrink, and -compositingrule.
+ * -subsample, -format, -shrink, -compositingrule, -alpha, -boolean and
+ * -withalpha.
+ * Parsing starts at the index in *optIndexPtr and stops at the end of
+ * objv[] or at the first value that does not belong to an option.
*
* Results:
* A standard Tcl result.
*
* Side effects:
- * Fields in *optPtr get filled in.
+ * Fields in *optPtr get filled in. The value of optIndexPtr is updated
+ * to contain the index of the first element in argv[] that was not
+ * parsed, or argc if the end of objv[] was reached.
*
*----------------------------------------------------------------------
*/
@@ -1593,7 +1568,8 @@ ParseSubcommandOptions(
return TCL_ERROR;
}
*optIndexPtr = index;
- } else if ((bit != OPT_SHRINK) && (bit != OPT_GRAYSCALE)) {
+ } else if (bit == OPT_TO || bit == OPT_FROM
+ || bit == OPT_SUBSAMPLE || bit == OPT_ZOOM) {
const char *val;
maxValues = ((bit == OPT_FROM) || (bit == OPT_TO)) ? 4 : 2;
@@ -2549,7 +2525,7 @@ MatchStringFormat(
int *oldformat) /* Returns 1 if the old image API is used. */
{
int matched = 0, useoldformat = 0;
- Tk_PhotoImageFormat *formatPtr;
+ Tk_PhotoImageFormat *formatPtr, *defaultFormatPtr = NULL;
ThreadSpecificData *tsdPtr =
Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
const char *formatString = NULL;
@@ -2565,6 +2541,16 @@ MatchStringFormat(
for (formatPtr = tsdPtr->formatList; formatPtr != NULL;
formatPtr = formatPtr->nextPtr) {
+ /*
+ * To keep the behaviour of older versions (Tk <= 8.6), the default
+ * list-of-lists string format is checked last. Remember its position.
+ */
+
+ if (strncasecmp("default", formatPtr->name, strlen(formatPtr->name))
+ == 0) {
+ defaultFormatPtr = formatPtr;
+ }
+
if (formatObj != NULL) {
if (strncasecmp(formatString,
formatPtr->name, strlen(formatPtr->name)) != 0) {
@@ -2580,6 +2566,16 @@ MatchStringFormat(
return TCL_ERROR;
}
}
+
+ /*
+ * If this is the default format, and it was not passed as -format
+ * option, skip the stringMatchProc test. It'll be done later
+ */
+
+ if (formatObj == NULL && formatPtr == defaultFormatPtr) {
+ continue;
+ }
+
if ((formatPtr->stringMatchProc != NULL)
&& (formatPtr->stringReadProc != NULL)
&& formatPtr->stringMatchProc(data, formatObj,
@@ -2617,23 +2613,46 @@ MatchStringFormat(
}
}
}
+
if (formatPtr == NULL) {
- if ((formatObj != NULL) && !matched) {
+ /*
+ * Try the default format as last resort (only if no -format option
+ * was passed).
+ */
+
+ if ( formatObj == NULL && defaultFormatPtr == NULL) {
+ Tcl_Panic("default image format handler not registered");
+ }
+ if ( formatObj == NULL
+ && defaultFormatPtr->stringMatchProc != NULL
+ && defaultFormatPtr->stringReadProc != NULL
+ && defaultFormatPtr->stringMatchProc(data, formatObj,
+ widthPtr, heightPtr, interp) != 0) {
+ useoldformat = 0;
+ formatPtr = defaultFormatPtr;
+ } else if ((formatObj != NULL) && !matched) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"image format \"%s\" is not supported", formatString));
Tcl_SetErrorCode(interp, "TK", "LOOKUP", "PHOTO_FORMAT",
formatString, NULL);
+ return TCL_ERROR;
} else {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"couldn't recognize image data", -1));
Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO",
"UNRECOGNIZED_DATA", NULL);
+ return TCL_ERROR;
}
- return TCL_ERROR;
}
*imageFormatPtr = formatPtr;
*oldformat = useoldformat;
+
+ /*
+ * Some stringMatchProc might have left error messages and error codes in
+ * interp. Clear them before return.
+ */
+ Tcl_ResetResult(interp);
return TCL_OK;
}
@@ -3851,57 +3870,6 @@ ImgGetPhoto(
/*
*----------------------------------------------------------------------
*
- * ImgStringWrite --
- *
- * Default string write function. The data is formatted in the default
- * format as accepted by the "<img> put" command.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * See the user documentation.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-ImgStringWrite(
- Tcl_Interp *interp,
- Tcl_Obj *formatString,
- Tk_PhotoImageBlock *blockPtr)
-{
- int greenOffset, blueOffset;
- Tcl_Obj *data;
-
- greenOffset = blockPtr->offset[1] - blockPtr->offset[0];
- blueOffset = blockPtr->offset[2] - blockPtr->offset[0];
-
- data = Tcl_NewObj();
- if ((blockPtr->width > 0) && (blockPtr->height > 0)) {
- int row, col;
-
- for (row=0; row<blockPtr->height; row++) {
- Tcl_Obj *line = Tcl_NewObj();
- unsigned char *pixelPtr = blockPtr->pixelPtr + blockPtr->offset[0]
- + row * blockPtr->pitch;
-
- for (col=0; col<blockPtr->width; col++) {
- Tcl_AppendPrintfToObj(line, "%s#%02x%02x%02x",
- col ? " " : "", *pixelPtr,
- pixelPtr[greenOffset], pixelPtr[blueOffset]);
- pixelPtr += blockPtr->pixelSize;
- }
- Tcl_ListObjAppendElement(NULL, data, line);
- }
- }
- Tcl_SetObjResult(interp, data);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* Tk_PhotoGetImage --
*
* This function is called to obtain image data from a photo image. This
@@ -3944,7 +3912,7 @@ Tk_PhotoGetImage(
/*
*--------------------------------------------------------------
*
- * TkPostscriptPhoto --
+ * ImgPostscriptPhoto --
*
* This function is called to output the contents of a photo image in
* Postscript by calling the Tk_PostscriptPhoto function.
@@ -4081,5 +4049,6 @@ Tk_PhotoSetSize_Panic(
* mode: c
* c-basic-offset: 4
* fill-column: 78
+ * tab-width: 8
* End:
*/
diff --git a/generic/tkInt.decls b/generic/tkInt.decls
index a13d8d7..19deb98 100644
--- a/generic/tkInt.decls
+++ b/generic/tkInt.decls
@@ -634,6 +634,13 @@ declare 184 {
Tk_Font tkfont, const char *source, int numBytes, double x,
double y, double angle)
}
+
+# Debugging / testing functions for photo images
+declare 185 {
+ int TkDebugPhotoStringMatchDef(Tcl_Interp *inter, Tcl_Obj *data,
+ Tcl_Obj *formatString, int *widthPtr, int *heightPtr)
+}
+
##############################################################################
diff --git a/generic/tkInt.h b/generic/tkInt.h
index 3138ffc..a52339d 100644
--- a/generic/tkInt.h
+++ b/generic/tkInt.h
@@ -945,6 +945,7 @@ MODULE_SCOPE const Tk_SmoothMethod tkBezierSmoothMethod;
MODULE_SCOPE Tk_ImageType tkBitmapImageType;
MODULE_SCOPE Tk_PhotoImageFormat tkImgFmtGIF;
MODULE_SCOPE void (*tkHandleEventProc) (XEvent* eventPtr);
+MODULE_SCOPE Tk_PhotoImageFormat tkImgFmtDefault;
MODULE_SCOPE Tk_PhotoImageFormat tkImgFmtPNG;
MODULE_SCOPE Tk_PhotoImageFormat tkImgFmtPPM;
MODULE_SCOPE TkMainInfo *tkMainWindowList;
diff --git a/generic/tkIntDecls.h b/generic/tkIntDecls.h
index b8addbd..0ffe157 100644
--- a/generic/tkIntDecls.h
+++ b/generic/tkIntDecls.h
@@ -550,6 +550,10 @@ EXTERN void TkDrawAngledChars(Display *display,
Drawable drawable, GC gc, Tk_Font tkfont,
const char *source, int numBytes, double x,
double y, double angle);
+/* 185 */
+EXTERN int TkDebugPhotoStringMatchDef(Tcl_Interp *inter,
+ Tcl_Obj *data, Tcl_Obj *formatString,
+ int *widthPtr, int *heightPtr);
typedef struct TkIntStubs {
int magic;
@@ -767,6 +771,7 @@ typedef struct TkIntStubs {
void (*tkUnderlineAngledTextLayout) (Display *display, Drawable drawable, GC gc, Tk_TextLayout layout, int x, int y, double angle, int underline); /* 182 */
int (*tkIntersectAngledTextLayout) (Tk_TextLayout layout, int x, int y, int width, int height, double angle); /* 183 */
void (*tkDrawAngledChars) (Display *display, Drawable drawable, GC gc, Tk_Font tkfont, const char *source, int numBytes, double x, double y, double angle); /* 184 */
+ int (*tkDebugPhotoStringMatchDef) (Tcl_Interp *inter, Tcl_Obj *data, Tcl_Obj *formatString, int *widthPtr, int *heightPtr); /* 185 */
} TkIntStubs;
extern const TkIntStubs *tkIntStubsPtr;
@@ -1139,6 +1144,8 @@ extern const TkIntStubs *tkIntStubsPtr;
(tkIntStubsPtr->tkIntersectAngledTextLayout) /* 183 */
#define TkDrawAngledChars \
(tkIntStubsPtr->tkDrawAngledChars) /* 184 */
+#define TkDebugPhotoStringMatchDef \
+ (tkIntStubsPtr->tkDebugPhotoStringMatchDef) /* 185 */
#endif /* defined(USE_TK_STUBS) */
diff --git a/generic/tkStubInit.c b/generic/tkStubInit.c
index 7f5b3be..f760677 100644
--- a/generic/tkStubInit.c
+++ b/generic/tkStubInit.c
@@ -467,6 +467,7 @@ static const TkIntStubs tkIntStubs = {
TkUnderlineAngledTextLayout, /* 182 */
TkIntersectAngledTextLayout, /* 183 */
TkDrawAngledChars, /* 184 */
+ TkDebugPhotoStringMatchDef, /* 185 */
};
static const TkIntPlatStubs tkIntPlatStubs = {
diff --git a/generic/tkTest.c b/generic/tkTest.c
index 61153e5..483fc0d 100644
--- a/generic/tkTest.c
+++ b/generic/tkTest.c
@@ -206,6 +206,9 @@ static int TrivialConfigObjCmd(ClientData dummy,
Tcl_Obj * const objv[]);
static void TrivialEventProc(ClientData clientData,
XEvent *eventPtr);
+static int TestPhotoStringMatchCmd(ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj * const objv[]);
/*
*----------------------------------------------------------------------
@@ -269,6 +272,9 @@ Tktest_Init(
Tcl_CreateObjCommand(interp, "testprintf", TestprintfObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testtext", TkpTesttextCmd,
(ClientData) Tk_MainWindow(interp), NULL);
+ Tcl_CreateObjCommand(interp, "testphotostringmatch",
+ TestPhotoStringMatchCmd, (ClientData) Tk_MainWindow(interp),
+ NULL);
#if defined(_WIN32) || defined(MAC_OSX_TK)
Tcl_CreateObjCommand(interp, "testmetrics", TestmetricsObjCmd,
@@ -2124,6 +2130,54 @@ CustomOptionFree(
ckfree(*(char **)internalPtr);
}
}
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestPhotoStringMatchCmd --
+ *
+ * This function implements the "testphotostringmatch" command. It
+ * provides a way from Tcl to call the string match function for the
+ * default image handler directly.
+ *
+ * Results:
+ * A standard Tcl result. If data is in the proper format, the result in
+ * interp will contain width and height as a list. If the data cannot be
+ * parsed as default image format, returns TCL_ERROR and leaves an
+ * appropriate error message in interp.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+static int
+TestPhotoStringMatchCmd(
+ ClientData clientData, /* Main window for application. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument strings. */
+{
+ Tcl_Obj *dummy = NULL;
+ Tcl_Obj *resultObj[2];
+ int width, height;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "imageData");
+ return TCL_ERROR;
+ }
+ if (TkDebugPhotoStringMatchDef(interp, objv[1], dummy, &width, &height)) {
+ resultObj[0] = Tcl_NewIntObj(width);
+ resultObj[1] = Tcl_NewIntObj(height);
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObj));
+ return TCL_OK;
+ } else {
+ return TCL_ERROR;
+ }
+}
+
+
/*
* Local Variables:
diff --git a/generic/tkWindow.c b/generic/tkWindow.c
index ed57280..81d4f0d 100644
--- a/generic/tkWindow.c
+++ b/generic/tkWindow.c
@@ -334,6 +334,7 @@ CreateTopLevelWindow(
* Create built-in photo image formats.
*/
+ Tk_CreatePhotoImageFormat(&tkImgFmtDefault);
Tk_CreatePhotoImageFormat(&tkImgFmtGIF);
Tk_CreatePhotoImageFormat(&tkImgFmtPNG);
Tk_CreatePhotoImageFormat(&tkImgFmtPPM);
generated by cgit v0.12 at 2024-06-25 23:14:27 (GMT)