Added -withalpha option to [imageName get].

The list-of-lists-of-pixel-data format now is a registered format as the others.
Thanks to this change, [imageName data] now can return data that includes the alpha channel.
Changed the position of the '-alpha' and '-boolean' options to [imageName transparency set].
Updated doc
Updated test suite

8 files changed, 1356 insertions, 726 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 2eb674e..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,19 +191,6 @@ static int		ImgPhotoConfigureMaster(Tcl_Interp *interp,
 static int		ToggleComplexAlphaIfNeeded(PhotoMaster *mPtr);
 static int		ImgPhotoSetSize(PhotoMaster *masterPtr, int width,
 			    int height);
-static int		ImgStringMatch(Tcl_Obj *data, Tcl_Obj *format,
-			    int *widthPtr, int *heightPtr, Tcl_Interp *interp);
-static int		ImgStringRead(Tcl_Interp *interp, Tcl_Obj *data,
-			    Tcl_Obj *format, Tk_PhotoHandle imageHandle,
-			    int destX, int destY, int width, int height,
-			    int srcX, int srcY);
-static int		ImgStringWrite(Tcl_Interp *interp,
-			    Tcl_Obj *formatString,
-			    Tk_PhotoImageBlock *blockPtr);
-static int		ImgPhotoParseColor(Tcl_Interp *interp, 
-			    Tcl_Obj *specObj, unsigned char *redPtr, 
-			    unsigned char *greenPtr, unsigned char *bluePtr,
-			    unsigned char *alphaPtr);
 static char *		ImgGetPhoto(PhotoMaster *masterPtr,
 			    Tk_PhotoImageBlock *blockPtr,
 			    struct SubcommandOptions *optPtr);
@@ -661,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.
@@ -669,7 +666,7 @@ ImgPhotoCmd(
 
 	Tk_ImageStringWriteProc *stringWriteProc = NULL;
 
-	index = 2;
+	index = 1;
 	memset(&options, 0, sizeof(options));
 	options.name = NULL;
 	options.format = NULL;
@@ -680,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;
 	}
@@ -702,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;
 	}
 
 	/*
@@ -782,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: {
@@ -791,11 +803,23 @@ ImgPhotoCmd(
 	 */
 
 	Tcl_Obj *channels[4];
-
-	if (objc != 4) {
-	    Tcl_WrongNumArgs(interp, 2, objv, "x y");
+	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;
@@ -819,18 +843,21 @@ ImgPhotoCmd(
 	channels[1] = Tcl_NewIntObj(pixelPtr[1]);
 	channels[2] = Tcl_NewIntObj(pixelPtr[2]);
 	channels[3] = Tcl_NewIntObj(pixelPtr[3]);
-	Tcl_SetObjResult(interp, Tcl_NewListObj(4, channels));
+	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;
@@ -839,73 +866,51 @@ ImgPhotoCmd(
 	    Tcl_WrongNumArgs(interp, 2, objv, "data ?-option value ...?");
 	    return TCL_ERROR;
 	}
-	
+
 	/*
 	 * See if there's a format that can read the data
 	 */
-
-	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;
-	    }
-	    /*
-	     * 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.
-	     */
-	    masterPtr->flags |= IMAGE_CHANGED;
-	    return TCL_OK;
-	}
 	
-	/*
-	 * Try with the default format
-	 */
-	if (options.options & OPT_FORMAT) {
+	if (MatchStringFormat(interp, objv[2], options.format, &imageFormat,
+		&imageWidth, &imageHeight, &oldformat) != TCL_OK) {
 	    return TCL_ERROR;
 	}
-	Tcl_ResetResult(interp);
-	if ( ! ImgStringMatch(objv[2], NULL, &imageWidth, &imageHeight,
-		interp)) {
-	    return TCL_ERROR;	    
-	}
+
 	if (!(options.options & OPT_TO) || (options.toX2 < 0)) {
 	    options.toX2 = options.toX + imageWidth;
 	    options.toY2 = options.toY + imageHeight;
 	}
-	if (ImgStringRead(interp, objv[2], NULL, (Tk_PhotoHandle) masterPtr,
-		options.toX, options.toY, 
+	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,
 		options.toX2 - options.toX, 
 		options.toY2 - options.toY, 0, 0) != TCL_OK) {
 	    return TCL_ERROR;
 	}
-	
+	/*
+	 * 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.
+	 */
+	masterPtr->flags |= IMAGE_CHANGED;
+       
 	return TCL_OK;
-
+    }
     case PHOTO_READ: {
 	Tcl_Obj *format;
 
@@ -1075,8 +1080,11 @@ ImgPhotoCmd(
 
 	switch ((enum transOptions) index) {
 	case PHOTO_TRANS_GET: {
-	    const char *arg;
-	    int boolMode, strLength;
+	    int boolMode;
+
+	    /*
+	     * parse fixed args and option
+	     */
 	    
 	    if (objc > 6 || objc < 5) {
 		Tcl_WrongNumArgs(interp, 3, objv, "x y ?-option?");
@@ -1086,21 +1094,26 @@ ImgPhotoCmd(
 		    || (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 (objc == 6) {
-		arg = Tcl_GetStringFromObj(objv[5], &strLength);
-		if (strncmp(arg, "-boolean", (unsigned)strLength) == 0) {
-		    boolMode = 1;
-		} else if (strncmp(arg, "-alpha", (unsigned)strLength) == 0) {
-		    boolMode = 0;
-		} else {
-		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-			"unknown option \"%s\": must be -alpha or -boolean",
-			Tcl_GetString(objv[5])));
-		    Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO", "BAD_OPTION", NULL);
-		    return TCL_ERROR;
-		}
+	    if (options.options & OPT_ALPHA) {
+		boolMode = 0;
 	    }
+
 	    if ((x < 0) || (x >= masterPtr->width)
 		    || (y < 0) || (y >= masterPtr->height)) {
 		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -1111,15 +1124,9 @@ ImgPhotoCmd(
 		return TCL_ERROR;
 	    }
 
-	    /* What a way to do a test! */
-	    /* SB: indeed! Why don't we just get the information from image data? */
-	    /*
-		testRegion = TkCreateRegion();
-		TkUnionRectWithRegion(&testBox, testRegion, testRegion);
-		TkIntersectRegion(testRegion, masterPtr->validRegion, testRegion);
-		TkClipBox(testRegion, &testBox);
-		TkDestroyRegion(testRegion);
-	    */
+	    /* 
+	     * Extract and return the desired value
+	     */
 	    pixelPtr = masterPtr->pix32 + (y * masterPtr->width + x) * 4;
 	    if (boolMode) {
 		Tcl_SetObjResult(interp, Tcl_NewBooleanObj( ! pixelPtr[3]));
@@ -1130,64 +1137,75 @@ ImgPhotoCmd(
 	}
 
 	case PHOTO_TRANS_SET: {
-	    int newVal, boolMode, strLength;
-	    const char *arg;
+	    int newVal, boolMode;
+	    //const char *arg;
 	    XRectangle setBox;
 	    TkRegion modRegion;
 
+	    /* 
+	     * Parse args and option, check for valid values
+	     */
+	    
 	    if (objc < 6 || objc > 7) {
-		Tcl_WrongNumArgs(interp, 3, objv, "x y ?-option? newVal");
+		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)) {
 		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 (objc == 7) {
-		arg = Tcl_GetStringFromObj(objv[5], &strLength);
-		if (strncmp(arg, "-boolean", (unsigned) strLength) == 0) {
-		    boolMode = 1;
-		} else if (strncmp(arg, "-alpha", (unsigned) strLength) == 0) {
-		    boolMode = 0;
-		} else {
-		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-			"unknown option \"%s\": must be -alpha or -boolean",
-			Tcl_GetString(objv[5])));
-		    Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO", "BAD_OPTION", NULL);
-		    return TCL_ERROR;
-		}
+	    if (options.options & OPT_ALPHA) {
+		boolMode = 0;
 	    }
+
+	    if ((x < 0) || (x >= masterPtr->width)
+		|| (y < 0) || (y >= masterPtr->height)) {
+		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			"%s transparency set: coordinates out of range",
+			Tcl_GetString(objv[0])));
+		Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO", "COORDINATES",
+			NULL);
+		return TCL_ERROR;
+	    }
+
 	    if (boolMode) {
-		if (Tcl_GetBooleanFromObj(interp, objv[objc-1], &newVal) != TCL_OK) {
+		if (Tcl_GetBooleanFromObj(interp, objv[5], &newVal) != TCL_OK) {
 		    return TCL_ERROR;
 		}
 	    } else {
-		if (Tcl_GetIntFromObj(interp, objv[objc-1], &newVal) != TCL_OK) {
+		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);
+			    "invalid alpha value \"%d\": "
+			    "must be integer between 0 and 255", newVal));
+		    Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO",
+			    "BAD_VALUE", NULL);
 		    return TCL_ERROR;
 		}
 	    }
-	    
-	    if ((x < 0) || (x >= masterPtr->width)
-		|| (y < 0) || (y >= masterPtr->height)) {
-		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-			"%s transparency set: coordinates out of range",
-			Tcl_GetString(objv[0])));
-		Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO", "COORDINATES",
-			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;
@@ -1198,6 +1216,7 @@ ImgPhotoCmd(
 	    /*
 	     * Update the validRegion of the image
 	     */
+
 	    setBox.x = x;
 	    setBox.y = y;
 	    setBox.width = 1;
@@ -1413,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.
  *
  *----------------------------------------------------------------------
  */
@@ -1544,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;
@@ -2500,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;
@@ -2516,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) {
@@ -2531,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,
@@ -2568,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;
 }
 
@@ -3799,549 +3867,6 @@ ImgGetPhoto(
     return NULL;
 }
 
-/*
- *----------------------------------------------------------------------
- * 
- * Default Photo Image Format
- * ===========================
- * 
- * We have a default (or fallback) image format that is used for the 
- * "<img> put", "<img> get", and "<img> data" commands. Image data is
- * specified as a list of lists of pixel data. For details see the description
- * of the "<img> put" command in the documentation of photo(n). 
- * 
- * This default image format cannot read/write files, it is meant for string
- * data only. 
- * 
- * The default format is not registerd with Tk_CreatePhotoImageFromat()
- * 
- *----------------------------------------------------------------------
- */
- 
-/*
- *----------------------------------------------------------------------
- *
- * ImgStringMatch --
- *
- *	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 
- * 	messate 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
-ImgStringMatch(
-    Tcl_Obj *data,	/* The data to check */
-    Tcl_Obj *format, 	/* Value of the -format option, - NULL for this format */
-    int *widthPtr, 
-    int *heightPtr,	/* Size of the image in *data is written here */
-    Tcl_Interp *interp) /* ... */
-{
-    int y, rowCount, colCount, curColCount;
-    Tcl_Obj **rowListPtr;
-
-    /*
-     * See if data is a nonempty list and if each element has the same 
-     * length.
-     */
-
-    if (Tcl_ListObjGetElements(interp, data, &rowCount, &rowListPtr) 
-	    != TCL_OK) {
-	return 0;
-    }
-    if (rowCount == 0) {
-	/* empty list is actually 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;
-	}
-    }
-    
-    /*
-     * 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;
-	    
-}
- 
-/*
- *----------------------------------------------------------------------
- *
- * ImgStringRead --
- *
- *	Default string read function. The data is formatted in the default
- *	format as accepted by the "<img> put" command.
- *
- * 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.
- * 	See documentation for Tk_CreatePhotoImageFormat for further details.
- *
- *----------------------------------------------------------------------
-*/
-
-static int
-ImgStringRead(
-    Tcl_Interp *interp,			/* leave error messages here */
-    Tcl_Obj *data,			/* the data to parse */
-    Tcl_Obj *format, 			/* 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;
-    unsigned char *curPixelPtr;
-    int x, y, rowCount, colCount, curColCount;
-    Tk_PhotoImageBlock srcBlock;
-   
-    /*
-     * Check if we have valid 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;
-    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 (ImgPhotoParseColor(interp, colListPtr[x], 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;
-}
- 
-/*
- *----------------------------------------------------------------------
- *
- * ImgStringWrite --
- *
- *	Default string write function. The data is formatted in the default
- *	format as accepted by the "<img> put" command.
- *
- * Results:
- *	The converted data is set as the result of interp. Returns a standard 
- * 	Tcl result.
- *
- * Side effects:
- *	None.
- *
- *----------------------------------------------------------------------
- */
-
-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;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * ImgPhotoParseColor --
- *
- *	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
-ImgPhotoParseColor(
-    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)
-{
-    const char *specString, *suffixString, *colorString;
-    Tcl_Obj *colorObj = NULL;
-    char *tmpString;
-    unsigned int i, charCount;
-    double fracAlpha;
-    unsigned int colorAlpha, suffixAlpha;
-    XColor parsedColor;
-    Display *display;
-    Colormap colormap;
-    enum FormatType {
-	PHOTO_COLORFORMAT_TKCOLOR,
-	PHOTO_COLORFORMAT_EMPTYSTRING,
-	PHOTO_COLORFORMAT_LIST,
-	PHOTO_COLORFORMAT_ARGB1,
-	PHOTO_COLORFORMAT_ARGB2
-    } formatType;
-
-    /*
-     * Split color data string in color and suffix parts
-     */
-    
-    specString = Tcl_GetString(specObj);
-    if ((suffixString = strrchr(specString, '@')) == NULL
-	    && ((suffixString = strrchr(specString, '#')) == NULL
-	    || suffixString == specString)) {
-	suffixString = specString + strlen(specString);
-    }
-    colorObj = Tcl_NewStringObj(specString, suffixString - specString);
-    colorString = Tcl_GetString(colorObj);
-    
-    /*
-     * Parse the 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.
-     */
-    
-    display = Tk_Display(Tk_MainWindow(interp));
-    colormap = Tk_Colormap(Tk_MainWindow(interp));
-    if (TkParseColor(display, colormap, colorString, &parsedColor)) {
-	formatType = PHOTO_COLORFORMAT_TKCOLOR;
-	parsedColor.red >>= 8;
-	parsedColor.green >>= 8;
-	parsedColor.blue >>= 8;
-    } else if (colorString[0] == '#') {
-	charCount = strlen(colorString);
-	if (charCount - 1 != 4 && charCount - 1 != 8) {
-	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-		    "invalid color name \"%s\"", colorString));
-	    Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO", 
-		    "INVALID_COLOR", NULL);
-	    goto errorExit;
-	}
-	for (i = 1; i < charCount; i++) {
-	    if ( ! isxdigit(UCHAR(colorString[i]))) {
-		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-			"invalid color name \"%s\"", colorString));
-		Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO", 
-			"INVALID_COLOR", NULL);
-		goto errorExit;
-	    }
-	}
-	switch (charCount - 1) {
-	    case 4:
-		/* #ARGB format */
-		formatType = PHOTO_COLORFORMAT_ARGB1;
-		sscanf(colorString, "#%1x%1hx%1hx%1hx", &colorAlpha,
-			&parsedColor.red, &parsedColor.green, 
-			&parsedColor.blue);
-		parsedColor.red *= 0x11;
-		parsedColor.green *= 0x11;
-		parsedColor.blue *= 0x11;
-		colorAlpha *= 0x11;
-		break;
-	    case 8:
-		/* #AARRGGBB format */
-		formatType = PHOTO_COLORFORMAT_ARGB2;
-		sscanf(colorString, "#%2x%2hx%2hx%2hx", &colorAlpha,
-			&parsedColor.red, &parsedColor.green, 
-			&parsedColor.blue);
-		break;
-	    default:
-		Tcl_Panic("unexpected switch fallthrough");
-	}
-    } else if (strlen(colorString) == 0) {
-	formatType = PHOTO_COLORFORMAT_EMPTYSTRING;
-	parsedColor.red = 0;
-	parsedColor.green = 0;
-	parsedColor.blue = 0;
-	colorAlpha = 0;
-    } else {
-	int listLen;
-	int values[4];
-	Tcl_Obj *curValue;
-	
-	/* 
-	 * Last, try to interpret color as a tcl list 
-	 */
-	
-	if (Tcl_ListObjLength(interp, colorObj, &listLen) != TCL_OK
-		|| listLen < 3 || listLen > 4) {
-	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-		    "can't parse color \"%s\"", colorString));
-	    Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO", 
-		    "INVALID_COLOR", NULL);
-	    goto errorExit;
-	}
-	values[3] = -1;
-	for (i = 0; i < (unsigned)listLen; i++) {
-	    if (Tcl_ListObjIndex(interp, colorObj, i, &curValue) != TCL_OK) {
-		goto errorExit;
-	    }
-	    if (Tcl_GetIntFromObj(interp, curValue, values + i) != TCL_OK) {
-		goto errorExit;
-	    }
-	    if (values[i] < 0 || values[i] > 255) {
-		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-			"invalid color \"%s\": expected integers "
-			"in the range from 0 to 255", colorString));
-		Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO", 
-			"INVALID_COLOR", NULL);
-		goto errorExit;
-	    }
-	}
-	formatType = PHOTO_COLORFORMAT_LIST;
-	parsedColor.red = values[0];
-	parsedColor.green = values[1];
-	parsedColor.blue = values[2];
-	if (values[3] != -1) {
-	    colorAlpha = values[3];
-	} else {
-	    colorAlpha = 255;
-	}
-    }
-    
-    /*
-     * parse the Suffix
-     */
-    if (formatType != PHOTO_COLORFORMAT_TKCOLOR
-	    && suffixString[0] != '\0') {
-	Tcl_SetObjResult(interp, Tcl_ObjPrintf("invalid color \"%s\": "
-		"format does not allow alpha suffix", specString));
-	Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO", 
-		"INVALID_COLOR", NULL);
-	goto errorExit;
-    }
-    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");
-    }
-    
-    /*
-     * Put the pieces togegher and clean up
-     */
-    
-    *redPtr = parsedColor.red;
-    *greenPtr = parsedColor.green;
-    *bluePtr = parsedColor.blue;
-    if (formatType == PHOTO_COLORFORMAT_TKCOLOR) {
-	/* 
-	 * there was no alpha value in the color spec. use the one
-	 * from suffix, which is 255 if no suffix was passed.
-	 */
-	
-	*alphaPtr = suffixAlpha;
-    } else {
-	*alphaPtr = colorAlpha;
-    }
-    
-    if (colorObj != NULL) {
-	Tcl_DecrRefCount(colorObj);
-    }
-    
-    return TCL_OK;
-    
-  errorExit:
-    if (colorObj != NULL) {
-	Tcl_DecrRefCount(colorObj);
-    }
-    
-    return TCL_ERROR;
-    
-}
-
 /*
  *----------------------------------------------------------------------
  *
@@ -4524,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 1f801be..bd7b948 100644
--- a/generic/tkTest.c
+++ b/generic/tkTest.c
@@ -203,6 +203,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[]);
 
 /*
  *----------------------------------------------------------------------
@@ -265,6 +268,9 @@ Tktest_Init(
 	    (ClientData) Tk_MainWindow(interp), 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,
@@ -2066,6 +2072,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);