path: root/generic/tkImgListFormat.c

/*
 * 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);
}