Tk Source Code

.VS 8.7
.TP
\fBdefault \-colorformat\fI formatType\fR
.
The option is allowed when writing image data to a string with
\fIimageName\fR \fBdata\fR. Specifies the format to use for the color
string of each pixel. \fIformatType\fR may be one of: \fBrgb\fR to
encode pixel data in the form \fB#\fIRRGGBB\fR, \fBrgba\fR to encode
pixel data in the form \fB#\fIRRGGBBAA\fR or \fBlist\fR to encode
pixel data as a list with four elements. See \fBCOLOR FORMATS\fR
below for details. The default is \fBrgb\fR.
.VE 8.7
.TP
\fBgif \-index\fI indexValue\fR
.
The option has effect when reading image data from a file. When

(fully opaque). 
.RE
.IP \(bu 3
A Tcl list with three or four integers in the range 0 to 255, 
specifying the values for the red, green, blue and (optionally) 
alpha channels respectively.
.IP \(bu 3
\fB#\fR\fIRGBA\fR format: a \fB#\fR followed by four hexadecimal digits,
where each digit is the value for the red, green, blue and alpha
channels respectively. Each digit will be expanded internally to 
8 bits by multiplication by 0x11.
.IP \(bu 3
\fB#\fR\fIRRGGBBAA\fR format: \fB#\fR followed by eight hexadecimal digits,
where each pair of  subsequent digits represents the value for the red,
green, blue and alpha channels respectively.
.VE 8.7
.SH "COLOR ALLOCATION"
.PP
When a photo image is displayed in a window, the photo image code
allocates colors to use to display the image and dithers the image, if
necessary, to display a reasonable approximation to the image using
the colors that are available.  The colors are allocated as a color

 * 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

/*
 * Symbols for the different formats of a color string.
 */

enum ColorFormatType {
    COLORFORMAT_TKCOLOR,
    COLORFORMAT_EMPTYSTRING,
    COLORFORMAT_LIST,
    COLORFORMAT_RGB1,
    COLORFORMAT_RGB2,
    COLORFORMAT_RGBA1,
    COLORFORMAT_RGBA2
};

/*
 * 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",
    "rgba-short",
    "rgba",
    NULL
};

/*
 * The following data structure is used to return information from
 * ParseFormatOptions:
 */

                        "MISSING_VALUE", NULL);
                return TCL_ERROR;
            }
            if (Tcl_GetIndexFromObj(NULL, objv[index], colorFormatNames, "",
                    TCL_EXACT, &typeIndex) != TCL_OK
                    || (typeIndex != COLORFORMAT_LIST
                    && typeIndex != COLORFORMAT_RGB2
                    && typeIndex != COLORFORMAT_RGBA2) ) {
                Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad color format "
                        "\"%s\": must be rgb, rgba, or list",
                        Tcl_GetString(objv[index])));
                Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO",
                        "BAD_COLOR_FORMAT", NULL);
                return TCL_ERROR;
            }
            optPtr->colorFormat = typeIndex;
            break;

    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;

            Tcl_DStringInit(&line);
            for (col=0; col<blockPtr->width; col++) {
                if (hasAlpha) {
                    alphaVal = pixelPtr[alphaOffset];
                }

                /*
                 * We don't build lines as a list for #RGBA and #RGB. Since 
                 * these color formats look like comments, the first element
                 * of the list would get quoted with an additional {} . 
                 * While this is not a problem if the data is used as
                 * a list, it would cause problems if someone decides to parse
                 * it as a string (and it looks kinda strange)
                 */

                switch (opts.colorFormat) {
                case COLORFORMAT_RGB2:
                    sprintf(colorBuf, "#%02x%02x%02x ",  pixelPtr[0],
                            pixelPtr[greenOffset], pixelPtr[blueOffset]);
                    Tcl_DStringAppend(&line, colorBuf, -1);
                    break;
                case COLORFORMAT_RGBA2:
                    sprintf(colorBuf, "#%02x%02x%02x%02x ",
                            pixelPtr[0], pixelPtr[greenOffset],
                            pixelPtr[blueOffset], alphaVal);
                    Tcl_DStringAppend(&line, colorBuf, -1);
                    break;
                case COLORFORMAT_LIST:
                    Tcl_DStringStartSublist(&line);
                    sprintf(colorBuf, "%d", pixelPtr[0]);
                    Tcl_DStringAppendElement(&line, colorBuf);
                    sprintf(colorBuf, "%d", pixelPtr[greenOffset]);

                default:
                    Tcl_Panic("unexpected switch fallthrough");
                }
                pixelPtr += blockPtr->pixelSize;
            }
            if (opts.colorFormat != COLORFORMAT_LIST) {
                /*
                 * For the #XXX formats, we need to remove the last
                 * whitespace.
                 */
                
                *(Tcl_DStringValue(&line) + Tcl_DStringLength(&line) - 1)
                        = '\0';
            }
            Tcl_DStringAppendElement(&data, Tcl_DStringValue(&line));

    unsigned char *bluePtr,
    unsigned char *alphaPtr)
{
    const char *specString;
    int charCount;
    
    /*
     * Find out which color format we have
     */
    
    specString = Tcl_GetStringFromObj(specObj, &charCount);
    
    if (charCount == 0) {
        /* Empty string */
        *redPtr = *greenPtr = *bluePtr = *alphaPtr = 0;

/*
 *----------------------------------------------------------------------
 *
 * ParseColorAsHex --
 *
 *      This function extracts color and alpha values from a string
 *      starting with '#', followed by hex digits. It undestands both
 *      the #RGBA form and the #RBG (with optional suffix)
 *
 * 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. 
 *      Returns a standard Tcl result.
 *

                    display, colormap, redPtr, greenPtr, bluePtr, alphaPtr);
        }
    }
    
    colorValue = strtoul(colorString + 1, NULL, 16);
    switch (colorStrLen - 1) {
    case 4:
        /* #RGBA format */
        *redPtr = (unsigned char) ((colorValue >> 12) * 0x11);
        *greenPtr = (unsigned char) (((colorValue >> 8) & 0xf) * 0x11);
        *bluePtr = (unsigned char) (((colorValue >> 4) & 0xf) * 0x11);
        *alphaPtr = (unsigned char) ((colorValue & 0xf) * 0x11);
        return TCL_OK;
    case 8:
        /* #RRGGBBAA format */
        *redPtr = (unsigned char) (colorValue >> 24);
        *greenPtr = (unsigned char) ((colorValue >> 16) & 0xff);
        *bluePtr = (unsigned char) ((colorValue >> 8) & 0xff);
        *alphaPtr = (unsigned char) (colorValue & 0xff);
        return TCL_OK;
    default:
        Tcl_Panic("unexpected switch fallthrough");
    }

    /* Shouldn't get here */
    return TCL_ERROR;

# This file is a Tcl script to test out the default image data format
# ("list format") implementend in the file tkImgListFormat.c.
# It is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 2017 Simon Bachmann
# All rights reserved.
#
# Author: Simon Bachmann ([email protected])

package require tcltest 2.2
namespace import ::tcltest::*
tcltest::configure {*}$argv

    image create photo photo1
} -body {
    photo1 put yellow
    photo1 data -format {default -colorformat bogus}
} -cleanup {
    imageCleanup
} -returnCodes error -result \
    {bad color format "bogus": must be rgb, rgba, or list}
test imgListFormat-1.7 {ParseFormatOptions: bad -colorformat val #2} -setup {
    image create photo photo1
} -body {
    photo1 data -format {default -colorformat tkcolor}
} -returnCodes error -result \
    {bad color format "tkcolor": must be rgb, rgba, or list}
test imgListFormat-1.8 {ParseFormatOptions: bad -colorformat #3} -setup {
    image create photo photo1
} -body {
    photo1 data -format {default -colorformat emptystring}
} -returnCodes error -result \
    {bad color format "emptystring": must be rgb, rgba, or list}
test imgListFormat-1.9 {ParseFormatOptions: bad -colorformat #4} -setup {
    image create photo photo1
} -body {
    photo1 data -format {default -colorformat rgb-short}
} -cleanup {
    imageCleanup
} -returnCodes error -result \
    {bad color format "rgb-short": must be rgb, rgba, or list}
test imgListFormat-1.10 {ParseFormatOptions: bad -colorformat #5} -setup {
    image create photo photo1
} -body {
    photo1 data -format {default -colorformat rgba-short}
} -returnCodes error -result \
    {bad color format "rgba-short": must be rgb, rgba, or list}
test imgListFormat-1.11 {valid colorformats} -setup {
    image create photo photo1
} -body {
    photo1 put white#78
    set result {}
    lappend result [photo1 data -format {default -colorformat rgb}]
    lappend result [photo1 data -format {default -colorformat rgba}]
    lappend result [photo1 data -format {default -colorformat list}]
    set result
} -cleanup {
    imageCleanup
    unset result
} -result {{{#ffffff}} {{#ffffff78}} {{{255 255 255 120}}}}

# GetBadOptMsg: only use case already tested with imgListFormat-1.4
    
test imgListFormat-3.1 {StringMatchDef: data is not a list} -body {
    testphotostringmatch {not a " proper list}
    # " (this comment is here only for editor highlighting)
} -returnCodes error -result {unmatched open quote in list}

test imgListFormat-4.5 {StringReadDef: correct compositing rule} -constraints {
    hasTranspTeapotPhoto
} -setup {
    image create photo photo1 -file $transpTeapotPhotoFile
    image create photo photo2
} -body {
    photo2 put #FF0000 -to 0 0 50 50
    photo2 put [photo1 data -format {default -colorformat rgba}] -to 10 10 40 40
    list [photo2 get 0 0 -withalpha] [photo2 get 20 25 -withalpha] \
	[photo2 get 49 49 -withalpha]
} -cleanup {
    imageCleanup
} -result {{255 0 0 255} {0 78 185 225} {255 0 0 255}}

test imgListFormat-5.1 {StringWriteDef: format options not a list} -setup {

    photo1 data -format {default -colorformat list bogus}
} -cleanup {
    imageCleanup
} -returnCodes error -result {bad format option "bogus": must be -colorformat}
test imgListFormat-5.4 {StringWriteDef: empty image} -setup {
    image create photo photo1
} -body {
    photo1 data -format {default -colorformat rgba}
} -cleanup {
    imageCleanup
} -result {}
test imgListFormat-5.5 {StirngWriteDef: size of data} -setup {
    image create photo photo1
} -body {
    photo1 put blue -to 0 0 35 64

} -result {{#135cc0} #135cc0 #a06d52 #e1c8ba #135cc0}
test imgListFormat-5.7 {StringWriteDef: test some pixels #2} -constraints {
    hasTeapotPhoto
} -setup {
    set result {}
    image create photo photo1 -file $teapotPhotoFile
} -body {
    set imgData [photo1 data -format {default -colorformat rgba}]
    # note: with [lindex], the coords are inverted (y x)
    lappend result [lindex $imgData 0 0]
    lappend result [lindex $imgData 3 2]
    lappend result [lindex $imgData 107 53]
    lappend result [lindex $imgData 203 157]
    lappend result [lindex $imgData 255 255]
    set result 
} -cleanup {
    unset result
    unset imgData
    imageCleanup
} -result {{#135cc0ff} #135cc0ff #a06d52ff #e1c8baff #135cc0ff}
test imgListFormat-5.8 {StringWriteDef: test some pixels #3} -constraints {
    hasTranspTeapotPhoto
} -setup {
    image create photo photo1 -file $transpTeapotPhotoFile
} -body {
    set imgData [photo1 data -format {default -colorformat rgb}]
    set result {}

    imageCleanup
} -result {{#004eb9} #a14100 #ffca9f}
test imgListFormat-5.9 {StringWriteDef: test some pixels #4} -constraints {
    hasTranspTeapotPhoto
} -setup {
    image create photo photo1 -file $transpTeapotPhotoFile
} -body {
    set imgData [photo1 data -format {default -colorformat rgba}]
    set result [lindex $imgData 3 2]
    lappend result [lindex $imgData 107 53]
    lappend result [lindex $imgData 203 157]
    set result
} -cleanup {
    unset result
    unset imgData
    imageCleanup
} -result {{#004eb9e1} #a14100aa #ffca9faf}
test imgListFormat-5.10 {StringWriteDef: test some pixels #5} -constraints {
    hasTranspTeapotPhoto
} -setup {
    image create photo photo1 -file $transpTeapotPhotoFile
} -body {
    set imgData [photo1 data -format {default -colorformat list}]
    set result {}

    imageCleanup
    unset longstr
} -returnCodes error -result {invalid color}
test imgListFormat-6.4 {ParseColor: #XXX color, different forms} -setup {
    image create photo photo1
} -body {
    photo1 put {{#A123 #334455} {#012 #fffefd#00}}
    photo1 data -format {default -colorformat rgba}
} -cleanup {
    imageCleanup
} -result {{#aa112233 #334455ff} {#001122ff #fffefd00}}        
test imgListFormat-6.5 {ParseColor: list format} -setup {
    image create photo photo1
} -body {
    photo1 put [list [list [list 255 255 255]]]
    photo1 get 0 0 -withalpha
} -cleanup {
    imageCleanup

    image create photo photo1
    set result {}
} -body {
    photo1 put {
		{[email protected] snow#80 snow#8 #[email protected] #fffffabbfacc#8}
		{#fffffafffaff#80 #[email protected] #ffffaafaa#8 #ffffaafaa#80 #fee#8}
		{#fee#80 #[email protected] #[email protected] #fffafa#8 #fffafa#80}
		{{0xff 250 0xfa 128} {255 250 250} #fee8 #fffafa80 snow}}
    for {set y 0} {$y < 4} {incr y} {
		for {set x 0} {$x < 5} {incr x} {
			lappend result [photo1 get $x $y -withalpha]
		}
    }
    set result
} -cleanup {

} -cleanup {
    imageCleanup
} -result {{0 16 254 255} {0 100 254 255} {30 30 30 0} {1 1 254 1}}
test imgListFormat-7.9 {ParseColorAsList: additional spaces in list} -setup {
    image create photo photo1
} -body {
    photo1 put { { { 1 2 3} {1  2	 3} } { {1 2 3  } {  1  2  3   4  }  } }
    photo1 data -format {default -colorformat rgba}
} -cleanup {
    imageCleanup
} -result {{#010203ff #010203ff} {#010203ff #01020304}}
test imgListFormat-7.10 {ParseColorAsList: list format, string rep} -setup {
	image create photo photo1
} -body {
	photo1 put {{"111 222 33 44"}}
	photo1 get 0 0 -withalpha
} -cleanup {
	imageCleanup

    image create photo photo1
} -body {
    photo1 put {{#FFfFFf #AbCdef#0}}
    photo1 data
} -cleanup {
    imageCleanup
} -result {{#ffffff #abcdef}}
test imgListFormat-8.4 {ParseColor: valid #RGBA color} -setup {
    image create photo photo1
} -body {
    photo1 put {{#9bd5020d #7acF}}
    list [photo1 get 0 0 -withalpha] [photo1 get 1 0 -withalpha]
} -cleanup {
    imageCleanup
} -result {{155 213 2 13} {119 170 204 255}}

test imgListFormat-9.1 {ParseColorAsStandard:
        Tk color, valid suffixes} -setup {

} -body {
    photo1 put $imgData
    photo2 put $imgData -format default
    set result {}
    lappend result [list [image width photo1] [image height photo1]]
    lappend result [list [image width photo2] [image height photo2]]
    lappend result [string equal \
        [photo1 data -format "default -colorformat rgba"] \
        [photo2 data -format "default -colorformat rgba"]]
    set result
} -cleanup {
    imageCleanup
    unset result
    unset imgData
} -result {{3 2} {3 2} 1}
test imgPhoto-4.97 {ImgPhotoCmd put: image size} -setup {

    imageCleanup
} -returnCodes error -result {image string format "bogus" is unknown}
test imgPhoto-4.115 {ImgPhotoCmd data: rgb colorformat} -setup {
    image create photo photo1 -data {{red#a green#b} {blue#c white}}
} -body {
    photo1 data -format {default -colorformat rgb}
} -result {{#ff0000 #008000} {#0000ff #ffffff}}
test imgPhoto-4.116 {ImgPhotoCmd data: rgba colorformat} -setup {
    image create photo photo1 -data {{red green} {blue white}}
} -body {
    photo1 data -format {default -colorformat rgba}
} -result {{#ff0000ff #008000ff} {#0000ffff #ffffffff}}
test imgPhoto-4.117 {ImgPhotoCmd data: list colorformat} -setup {
    image create photo photo1 -data {{red#a green} {blue#c white#d}}
} -body {
    photo1 data -format {default -colorformat list}
} -result {{{255 0 0 170} {0 128 0 255}} {{0 0 255 204} {255 255 255 221}}}
test imgPhoto-4.118 {ImgPhotoCmd data: using data for new image 
    results in same image as orignial } -constraints {
        hasTeapotPhoto
        hasTranspTeapotPhoto
} -setup {
    image create photo teapot -file $teapotPhotoFile
    teapot copy teapot -from 50 60 70 80 -shrink
    image create photo teapotTransp -file $transpTeapotPhotoFile
    teapotTransp copy teapotTransp -from 100 110 120 130 -shrink
    image create photo photo1
} -body {
    set result {}
    # We don't test gif here, as there seems to be a problem with 
    # <imgName> data and gif format ("too many colors", probably a bug)
    foreach fmt {ppm png {default -colorformat rgba} \
            {default -colorformat list}} {
        set imgData [teapotTransp data -format $fmt]
        photo1 blank
        photo1 put $imgData
        if { ! [string equal [photo1 data] [teapotTransp data]]} {
            lappend result $fmt
        }