return TCL_ERROR;

}

}

}

}

/*

*/

case PHOTO_READ: {

Tcl_Obj *format;

switch ((enum transOptions) index) {

case PHOTO_TRANS_GET: {

return TCL_ERROR;

}

if ((Tcl_GetIntFromObj(interp, objv[3], &x) != TCL_OK)

|| (Tcl_GetIntFromObj(interp, objv[4], &y) != TCL_OK)) {

return TCL_ERROR;

}

if ((x < 0) || (x >= masterPtr->width)

|| (y < 0) || (y >= masterPtr->height)) {

Tcl_SetObjResult(interp, Tcl_ObjPrintf(

return TCL_ERROR;

}

return TCL_OK;

}

case PHOTO_TRANS_SET: {

XRectangle setBox;

return TCL_ERROR;

}

if ((Tcl_GetIntFromObj(interp, objv[3], &x) != TCL_OK)

return TCL_ERROR;

}

if ((x < 0) || (x >= masterPtr->width)

|| (y < 0) || (y >= masterPtr->height)) {

Tcl_SetObjResult(interp, Tcl_ObjPrintf(

return TCL_ERROR;

}

setBox.x = x;

setBox.y = y;

setBox.width = 1;

setBox.height = 1;

masterPtr->validRegion);

} else {

masterPtr->validRegion);

}

/*

* Inform the generic image code that the image

*

* This function is invoked to process one of the options which may be

* specified for the photo image subcommands, namely, -from, -to, -zoom,

*

* Results:

* A standard Tcl result.

*

* Side effects:

*

*----------------------------------------------------------------------

*/

return TCL_ERROR;

}

*optIndexPtr = index;

const char *val;

maxValues = ((bit == OPT_FROM) || (bit == OPT_TO)) ? 4 : 2;

int *oldformat) /* Returns 1 if the old image API is used. */

{

int matched = 0, useoldformat = 0;

ThreadSpecificData *tsdPtr =

Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));

const char *formatString = NULL;

for (formatPtr = tsdPtr->formatList; formatPtr != NULL;

formatPtr = formatPtr->nextPtr) {

if (formatObj != NULL) {

if (strncasecmp(formatString,

formatPtr->name, strlen(formatPtr->name)) != 0) {

return TCL_ERROR;

}

}

if ((formatPtr->stringMatchProc != NULL)

&& (formatPtr->stringReadProc != NULL)

&& formatPtr->stringMatchProc(data, formatObj,

}

}

}

if (formatPtr == NULL) {

Tcl_SetObjResult(interp, Tcl_ObjPrintf(

"image format \"%s\" is not supported", formatString));

Tcl_SetErrorCode(interp, "TK", "LOOKUP", "PHOTO_FORMAT",

formatString, NULL);

} else {

Tcl_SetObjResult(interp, Tcl_NewStringObj(

"couldn't recognize image data", -1));

Tcl_SetErrorCode(interp, "TK", "IMAGE", "PHOTO",

"UNRECOGNIZED_DATA", NULL);

}

}

*imageFormatPtr = formatPtr;

*oldformat = useoldformat;

return TCL_OK;

}



/*

*----------------------------------------------------------------------

*

* Tk_PhotoGetImage --

*

* This function is called to obtain image data from a photo image. This

/*

*--------------------------------------------------------------

*

*

* This function is called to output the contents of a photo image in

* Postscript by calling the Tk_PostscriptPhoto function.

* mode: c

* c-basic-offset: 4

* fill-column: 78

* End:

*/

Tk_Font tkfont, const char *source, int numBytes, double x,

double y, double angle)

}



##############################################################################

MODULE_SCOPE Tk_ImageType tkBitmapImageType;

MODULE_SCOPE Tk_PhotoImageFormat tkImgFmtGIF;

MODULE_SCOPE void (*tkHandleEventProc) (XEvent* eventPtr);

MODULE_SCOPE Tk_PhotoImageFormat tkImgFmtPNG;

MODULE_SCOPE Tk_PhotoImageFormat tkImgFmtPPM;

MODULE_SCOPE TkMainInfo *tkMainWindowList;

Drawable drawable, GC gc, Tk_Font tkfont,

const char *source, int numBytes, double x,

double y, double angle);

typedef struct TkIntStubs {

int magic;

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 */

} TkIntStubs;

extern const TkIntStubs *tkIntStubsPtr;

(tkIntStubsPtr->tkIntersectAngledTextLayout) /* 183 */

#define TkDrawAngledChars \

(tkIntStubsPtr->tkDrawAngledChars) /* 184 */

#endif /* defined(USE_TK_STUBS) */

TkUnderlineAngledTextLayout, /* 182 */

TkIntersectAngledTextLayout, /* 183 */

TkDrawAngledChars, /* 184 */

};

static const TkIntPlatStubs tkIntPlatStubs = {

Tcl_Obj * const objv[]);

static void TrivialEventProc(ClientData clientData,

XEvent *eventPtr);



/*

*----------------------------------------------------------------------

Tcl_CreateObjCommand(interp, "testprintf", TestprintfObjCmd, NULL, NULL);

Tcl_CreateObjCommand(interp, "testtext", TkpTesttextCmd,

(ClientData) Tk_MainWindow(interp), NULL);

#if defined(_WIN32) || defined(MAC_OSX_TK)

Tcl_CreateObjCommand(interp, "testmetrics", TestmetricsObjCmd,

ckfree(*(char **)internalPtr);

}

}



/*

* Local Variables:

nodePtr->numPixels[treePtr->pixelReferences-1];

}

if (treePtr->pixelReferences == 1) {

nodePtr->numPixels = NULL;

} else {

nodePtr->numPixels = ckrealloc(nodePtr->numPixels,

prevNodePtr->nextPtr = curNodePtr->nextPtr;

}

parentPtr->numChildren--;

ckfree(curNodePtr->numPixels);

ckfree(curNodePtr);

curNodePtr = parentPtr;

* Create built-in photo image formats.

*/

Tk_CreatePhotoImageFormat(&tkImgFmtGIF);

Tk_CreatePhotoImageFormat(&tkImgFmtPNG);

Tk_CreatePhotoImageFormat(&tkImgFmtPPM);

}

.console delete promptEnd end

.console insert promptEnd $cmd {input stdin}

}

next {

incr HistNum

}

.console delete promptEnd end

.console insert promptEnd $cmd {input stdin}

}

reset {

set HistNum 1

# Support for mousewheels on Linux/Unix commonly comes through mapping

# the wheel to the extended buttons. If you have a mousewheel, find

# Linux configuration info at:

bind Listbox <4> {

if {!$tk_strictMotif} {

%W yview scroll -5 units

# Support for mousewheels on Linux/Unix commonly comes through mapping

# the wheel to the extended buttons. If you have a mousewheel, find

# Linux configuration info at:

bind Text <4> {

if {!$tk_strictMotif} {

%W yview scroll -50 pixels

CGContextAddLineToPoint(dc.context, prevx, prevy);

}

}

CGContextStrokePath(dc.context);

}

TkMacOSXRestoreDrawingContext(&dc);

#

# Author: Paul Mackerras (paulus@cs.anu.edu.au)

package require tcltest 2.2

namespace import ::tcltest::*

tcltest::configure {*}$argv

tcltest::loadTestedCommands

proc foreachPixel {img xVar yVar script} {

upvar 1 $xVar x $yVar y

set width [image width $img]

# find the teapot.ppm file for use in these tests

set teapotPhotoFile [file join [file dirname [info script]] teapot.ppm]

testConstraint hasTeapotPhoto [file exists $teapotPhotoFile]

proc base64ok {} {

expr {

![catch {package require base64}]

test imgPhoto-1.11 {options for photo images - error case} -body {

image create photo photo1 -format

} -returnCodes error -result {value for "-format" missing}

test imgPhoto-2.1 {ImgPhotoCreate procedure} -setup {

imageCleanup

} -body {

# photo1 copy photo2

# set msg

# } {couldn't open "bogus.img": no such file or directory}

test imgPhoto-3.1 {ImgPhotoConfigureMaster procedure} -constraints {

hasTeapotPhoto

} -body {

destroy .c

image delete photo1

} -result {256 256 {10 10 266 266} {300 10 556 266}}

test imgPhoto-4.1 {ImgPhotoCmd procedure} -setup {

image create photo photo1

} -body {

} -cleanup {

image delete photo1 photo2

} -result {256 256 49 51 49 51 49 51 10 51 10 10}

test imgPhoto-4.22 {ImgPhotoCmd procedure: get option} -constraints {

} -setup {

image create photo photo1

} -body {

} -cleanup {

image delete photo1

test imgPhoto-4.23 {ImgPhotoCmd procedure: get option} -setup {

image create photo photo1

} -body {

test imgPhoto-4.25 {ImgPhotoCmd procedure: get option} -setup {

image create photo photo1

} -body {

} -cleanup {

image delete photo1

test imgPhoto-4.26 {ImgPhotoCmd procedure: put option} -setup {

image create photo photo1

} -body {

photo1 put {{white} {white white}}

} -returnCodes error -cleanup {

image delete photo1

test imgPhoto-4.28 {ImgPhotoCmd procedure: put option} -setup {

image create photo photo1

} -body {

photo1 put {{blahgle}}

} -cleanup {

image delete photo1

test imgPhoto-4.29 {ImgPhotoCmd procedure: put option} -setup {

image create photo photo1

} -body {

photo1 get 19 19

} -cleanup {

image delete photo1

} -result {255 255 255}

test imgPhoto-4.30 {ImgPhotoCmd procedure: read option} -setup {

image create photo photo1

} -body {

} -cleanup {

image delete photo1

} -returnCodes error -result {image file format "bogus" is unknown}

test imgPhoto-4.40 {ImgPhotoCmd procedure: transparency option} -setup {

image create photo photo1

} -body {

photo1 transparency get

} -returnCodes error -cleanup {

image delete photo1

test imgPhoto-4.42 {ImgPhotoCmd procedure: transparency get option} -setup {

image create photo photo1

} -body {

photo1 transparency get 0

} -returnCodes error -cleanup {

image delete photo1

test imgPhoto-4.43 {ImgPhotoCmd procedure: transparency get option} -setup {

image create photo photo1

} -body {

} -returnCodes error -cleanup {

image delete photo1

test imgPhoto-4.44 {ImgPhotoCmd procedure: transparency get option} -setup {

image create photo photo1

} -body {

} -cleanup {

image delete photo1

} -result 1

test imgPhoto-4.52 {ImgPhotoCmd procedure: transparency set option} -setup {

image create photo photo1

} -body {

photo1 transparency set

} -returnCodes error -cleanup {

image delete photo1

test imgPhoto-4.53 {ImgPhotoCmd procedure: transparency set option} -setup {

image create photo photo1

} -body {

photo1 transparency set 0

} -returnCodes error -cleanup {

image delete photo1

test imgPhoto-4.54 {ImgPhotoCmd procedure: transparency set option} -setup {

image create photo photo1

} -body {

photo1 transparency set 0 0

} -returnCodes error -cleanup {

image delete photo1

test imgPhoto-4.55 {ImgPhotoCmd procedure: transparency set option} -setup {

image create photo photo1

} -body {

} -returnCodes error -cleanup {

image delete photo1

test imgPhoto-4.56 {ImgPhotoCmd procedure: transparency set option} -setup {

image create photo photo1

} -body {

} -returnCodes error -result {expected integer but got "bogus"}

test imgPhoto-4.58 {ImgPhotoCmd procedure: transparency set option} -setup {

image create photo photo1

} -body {

photo1 transparency set 0 0 bogus

} -cleanup {

} -cleanup {

image delete photo1

} -result 1

# Now for some heftier testing, checking that setting and resetting of pixels'

# transparency status doesn't "leak" with any one-off errors.

test imgPhoto-4.65 {ImgPhotoCmd procedure: transparency get option} -setup {

image delete photo1

file delete ./-teapotPhotoFile

} -result {}

test imgPhoto-5.1 {ImgPhotoGet/Free procedures, shared instances} -constraints {

hasTeapotPhoto

} -setup {

} -cleanup {

destroy .c

} -result {}

test imgPhoto-6.1 {ImgPhotoDisplay procedure, blank display} -setup {

destroy .c

pack [canvas .c]

destroy .c

image delete photo1

} -result {}

test imgPhoto-7.1 {ImgPhotoFree procedure, resource freeing} -constraints {

hasTeapotPhoto

} -setup {

destroy .f

image delete photo1

} -result {}

test imgPhoto-8.1 {ImgPhotoDelete procedure} -constraints hasTeapotPhoto -body {

image create photo photo2 -file $teapotPhotoFile

image delete photo2

} -returnCodes error -cleanup {

imageCleanup

} -result {image "photo2" doesn't exist or is not a photo image}

test imgPhoto-9.1 {ImgPhotoCmdDeletedProc procedure} -constraints {

hasTeapotPhoto

} -body {

rename photo2 {}

list [lsearch -exact [imageNames] photo2] [catch {photo2 foo} msg] $msg

} -result {-1 1 {invalid command name "photo2"}}

test imgPhoto-10.1 {Tk_ImgPhotoPutBlock procedure} -setup {

imageCleanup

} -body {

imageCleanup

} -result {0 0}

test imgPhoto-11.1 {Tk_FindPhoto} -setup {

imageCleanup

} -body {

} -cleanup {

imageCleanup

} -returnCodes error -result {image "i1" doesn't exist or is not a photo image}

test imgPhoto-12.1 {Tk_PhotoPutZoomedBlock} -constraints hasTeapotPhoto -body {

image create photo p3 -file $teapotPhotoFile

set result [list [p3 get 50 50] [p3 get 100 100]]

interp delete x1

interp delete x2

} -result T1_data

test imgPhoto-14.1 {GIF writes work correctly} -setup {

set data {

R0lGODlhYwA5APcAAAAAAIAAAACAAICAAAAAgIAAgACAgICAgAysnGy8hKzM

} -cleanup {

image delete $i

} -returnCodes error -result {malformed image}

test imgPhoto-15.1 {photo images can fail to allocate memory gracefully} -constraints {

nonPortable

} -body {

# free memory available...

image create photo -width 32000 -height 32000

} -returnCodes error -result {not enough free memory for image buffer}

test imgPhoto-16.1 {copying to self doesn't access freed memory} -setup {

set i [image create photo]

} -body {

} -cleanup {

image delete $i

} -result {}

# Check that we can guess our supported output formats [Bug 2983824]

test imgPhoto-17.1 {photo write: format guessing from filename} -setup {

set i [image create photo -width 3 -height 3]

image delete $i

catch {removeFile $f}

} -result "P6\n"

# Reject corrupted or truncated image [Bug b601ce3ab1].

# WARNING - tests 18.1-18.9 will cause a segfault on 8.5.19 and lower,

} -setup {

package require base64

set data [base64::decode {

5qpraXIvM1JlNyAgOw==

}]

} -body {

} -returnCodes error -result {error reading color map|not enough free memory for image buffer} -match regexp

test imgPhoto-18.2 {Reject corrupted GIF (base 64 string)} -setup {

set data {

5qpraXIvM1JlNyAgOw==

}

} -body {

catch {image delete gif1}

} -returnCodes error -result {error reading color map}

test imgPhoto-18.7 {Reject corrupted GIF (> 4Gb) (binary string)} -constraints {

} -setup {

package require base64

set data [base64::decode {

R0lGODlhwmYz//8zM/8z/zP/MzP/////M////yH5Ciwhe

} -cleanup {

catch {image delete gif1}

} -returnCodes error -result {error reading color map|not enough free memory for image buffer} -match regexp

set data {

R0lGODlhwmYz//8zM/8z/zP/MzP/////M////yH5Ciwhe

LrcLTBCd6Tv2qW16tdK4jhV5qpraXIvM1JlNyAgOw==

} -cleanup {

catch {image delete gif1}

} -returnCodes error -result {error reading color map|not enough free memory for image buffer} -match regexp

set fileName [file join [file dirname [info script]] corruptMangled4G.gif]

} -body {

image create photo gif1 -file $fileName