Tk
view release on metacpan or search on metacpan
pTk/mTk/additions/imgWindow.c view on Meta::CPAN
int destX, destY;
int width, height;
int srcX, srcY;
{
myblock bl;
Tk_Window tkwin;
int fileWidth, fileHeight, i, depth, ncolors, nBytes, x, y;
char *name;
#ifndef __WIN32__
XImage *ximage;
ColormapData cdata;
#else
# undef XGetPixel
# define XGetPixel(P,X,Y) GetPixel(P, X, Y)
TkWinDCState DCi;
HDC ximage;
#endif
Colormap cmap;
Visual *visual;
unsigned char *p;
#ifdef X_GetImage
pTk/mTk/additions/imgWindow.c view on Meta::CPAN
#ifndef __WIN32__
cmap = Tk_Colormap(tkwin);
/*
* Obtain information about the colormap, ie the mapping between
* pixel values and RGB values. The code below should work
* for all Visual types.
*/
ncolors = visual->map_entries;
cdata.colors = (XColor *) ckalloc(sizeof(XColor) * ncolors);
cdata.ncolors = ncolors;
if (visual->class == DirectColor || visual->class == TrueColor) {
cdata.separated = 1;
cdata.red_mask = visual->red_mask;
cdata.green_mask = visual->green_mask;
cdata.blue_mask = visual->blue_mask;
cdata.red_shift = 0;
cdata.green_shift = 0;
cdata.blue_shift = 0;
while ((0x0001 & (cdata.red_mask >> cdata.red_shift)) == 0)
cdata.red_shift ++;
while ((0x0001 & (cdata.green_mask >> cdata.green_shift)) == 0)
cdata.green_shift ++;
while ((0x0001 & (cdata.blue_mask >> cdata.blue_shift)) == 0)
cdata.blue_shift ++;
for (i = 0; i < ncolors; i ++)
cdata.colors[i].pixel =
((i << cdata.red_shift) & cdata.red_mask) |
((i << cdata.green_shift) & cdata.green_mask) |
((i << cdata.blue_shift) & cdata.blue_mask);
} else {
cdata.separated=0;
for (i = 0; i < ncolors; i ++) cdata.colors[i].pixel = i;
}
cdata.color = !(visual->class == StaticGray || visual->class == GrayScale);
XQueryColors(Tk_Display(tkwin), cmap, cdata.colors, ncolors);
#endif
Tk_PhotoExpand(imageHandle, destX + width, destY + height);
block.offset[0] = 0;
block.offset[3] = 0;
#ifndef __WIN32__
if (cdata.color) {
#endif
block.pixelSize = 3;
block.offset[1] = green = 1;
block.offset[2] = blue = 2;
#ifndef __WIN32__
} else {
block.pixelSize = 1;
block.offset[1] = green = 0;
block.offset[2] = blue = 0;
}
pTk/mTk/additions/imgWindow.c view on Meta::CPAN
block.height = height;
block.pitch = block.pixelSize * width;
nBytes = block.pitch * height;
block.pixelPtr = (unsigned char *) ckalloc((unsigned) nBytes);
p = block.pixelPtr;
for (y = 0; y<height; y++) {
for (x = 0; x<width; x++) {
unsigned long pixel = XGetPixel(ximage, x, y);
#ifndef __WIN32__
if (cdata.separated) {
int r = (pixel & cdata.red_mask) >> cdata.red_shift;
p[0] = cdata.colors[r].red >> 8;
if (cdata.color) {
int g = (pixel & cdata.green_mask) >> cdata.green_shift;
int b = (pixel & cdata.blue_mask) >> cdata.blue_shift;
p[1] = cdata.colors[g].green >> 8;
p[2] = cdata.colors[b].blue >> 8;
}
} else {
p[0] = cdata.colors[pixel].red >> 8;
if (cdata.color) {
p[1] = cdata.colors[pixel].green >> 8;
p[2] = cdata.colors[pixel].blue >> 8;
}
}
#else
p[0] = GetRValue(pixel);
p[1] = GetGValue(pixel);
p[2] = GetBValue(pixel);
#endif
p += block.pixelSize;
}
}
Tk_PhotoPutBlock(imageHandle, &block, destX, destY, width, height, TK_PHOTO_COMPOSITE_SET);
#ifndef __WIN32__
XDestroyImage(ximage);
ckfree((char *) cdata.colors);
#else
# undef XGetPixel
TkWinReleaseDrawableDC(Tk_WindowId(tkwin), ximage, &DCi);
#endif
ckfree((char *) block.pixelPtr);
return TCL_OK;
}
pTk/mTk/generic/tkCanvPs.c view on Meta::CPAN
#include <windows.h>
/*
* We could just define these instead of pulling in windows.h.
#define GetRValue(rgb) ((BYTE)(rgb))
#define GetGValue(rgb) ((BYTE)(((WORD)(rgb)) >> 8))
#define GetBValue(rgb) ((BYTE)((rgb)>>16))
*/
static void
TkImageGetColor(cdata, pixel, red, green, blue)
TkColormapData *cdata; /* Colormap data */
unsigned long pixel; /* Pixel value to look up */
double *red, *green, *blue; /* Color data to return */
{
*red = (double) GetRValue(pixel) / 255.0;
*green = (double) GetGValue(pixel) / 255.0;
*blue = (double) GetBValue(pixel) / 255.0;
}
#else
static void
TkImageGetColor(cdata, pixel, red, green, blue)
TkColormapData *cdata; /* Colormap data */
unsigned long pixel; /* Pixel value to look up */
double *red, *green, *blue; /* Color data to return */
{
if (cdata->separated) {
int r = (pixel & cdata->red_mask) >> cdata->red_shift;
int g = (pixel & cdata->green_mask) >> cdata->green_shift;
int b = (pixel & cdata->blue_mask) >> cdata->blue_shift;
*red = cdata->colors[r].red / 65535.0;
*green = cdata->colors[g].green / 65535.0;
*blue = cdata->colors[b].blue / 65535.0;
} else {
*red = cdata->colors[pixel].red / 65535.0;
*green = cdata->colors[pixel].green / 65535.0;
*blue = cdata->colors[pixel].blue / 65535.0;
}
}
#endif
/*
*--------------------------------------------------------------
*
* TkPostscriptImage --
*
* This procedure is called to output the contents of an
pTk/mTk/generic/tkCanvPs.c view on Meta::CPAN
{
TkPostscriptInfo *psInfoPtr = (TkPostscriptInfo *) psInfo;
char buffer[256];
int xx, yy, band, maxRows;
double red, green, blue;
int bytesPerLine=0, maxWidth=0;
int level = psInfoPtr->colorLevel;
Colormap cmap;
int i, ncolors;
Visual *visual;
TkColormapData cdata;
if (psInfoPtr->prepass) {
return TCL_OK;
}
cmap = Tk_Colormap(tkwin);
visual = Tk_Visual(tkwin);
/*
* Obtain information about the colormap, ie the mapping between
* pixel values and RGB values. The code below should work
* for all Visual types.
*/
ncolors = visual->map_entries;
cdata.colors = (XColor *) ckalloc(sizeof(XColor) * ncolors);
cdata.ncolors = ncolors;
if (visual->class == DirectColor || visual->class == TrueColor) {
cdata.separated = 1;
cdata.red_mask = visual->red_mask;
cdata.green_mask = visual->green_mask;
cdata.blue_mask = visual->blue_mask;
cdata.red_shift = 0;
cdata.green_shift = 0;
cdata.blue_shift = 0;
while ((0x0001 & (cdata.red_mask >> cdata.red_shift)) == 0)
cdata.red_shift ++;
while ((0x0001 & (cdata.green_mask >> cdata.green_shift)) == 0)
cdata.green_shift ++;
while ((0x0001 & (cdata.blue_mask >> cdata.blue_shift)) == 0)
cdata.blue_shift ++;
for (i = 0; i < ncolors; i ++)
cdata.colors[i].pixel =
((i << cdata.red_shift) & cdata.red_mask) |
((i << cdata.green_shift) & cdata.green_mask) |
((i << cdata.blue_shift) & cdata.blue_mask);
} else {
cdata.separated=0;
for (i = 0; i < ncolors; i ++)
cdata.colors[i].pixel = i;
}
if (visual->class == StaticGray || visual->class == GrayScale)
cdata.color = 0;
else
cdata.color = 1;
XQueryColors(Tk_Display(tkwin), cmap, cdata.colors, ncolors);
/*
* Figure out which color level to use (possibly lower than the
* one specified by the user). For example, if the user specifies
* color with monochrome screen, use gray or monochrome mode instead.
*/
if (!cdata.color && level == 2) {
level = 1;
}
if (!cdata.color && cdata.ncolors == 2) {
level = 0;
}
/*
* Check that at least one row of the image can be represented
* with a string less than 64 KB long (this is a limit in the
* Postscript interpreter).
*/
switch (level) {
pTk/mTk/generic/tkCanvPs.c view on Meta::CPAN
case 1: bytesPerLine = width; maxWidth = 60000; break;
case 2: bytesPerLine = 3 * width; maxWidth = 20000; break;
}
if (bytesPerLine > 60000) {
Tcl_ResetResult(interp);
sprintf(buffer,
"Can't generate Postscript for images more than %d pixels wide",
maxWidth);
Tcl_AppendResult(interp, buffer, (char *) NULL);
ckfree((char *) cdata.colors);
return TCL_ERROR;
}
maxRows = 60000 / bytesPerLine;
for (band = height-1; band >= 0; band -= maxRows) {
int rows = (band >= maxRows) ? maxRows : band + 1;
int lineLen = 0;
switch (level) {
case 0:
pTk/mTk/generic/tkCanvPs.c view on Meta::CPAN
switch (level) {
case 0: {
/*
* Generate data for image in monochrome mode.
* No attempt at dithering is made--instead, just
* set a threshold.
*/
unsigned char mask=0x80;
unsigned char data=0x00;
for (xx = x; xx< x+width; xx++) {
TkImageGetColor(&cdata, XGetPixel(ximage, xx, yy),
&red, &green, &blue);
if (0.30 * red + 0.59 * green + 0.11 * blue > 0.5)
data |= mask;
mask >>= 1;
if (mask == 0) {
sprintf(buffer, "%02X", data);
Tcl_AppendResult(interp, buffer, (char *) NULL);
lineLen += 2;
if (lineLen > 60) {
lineLen = 0;
pTk/mTk/generic/tkCanvPs.c view on Meta::CPAN
data=0x00;
}
break;
}
case 1: {
/*
* Generate data in gray mode--in this case, take a
* weighted sum of the red, green, and blue values.
*/
for (xx = x; xx < x+width; xx ++) {
TkImageGetColor(&cdata, XGetPixel(ximage, xx, yy),
&red, &green, &blue);
sprintf(buffer, "%02X", (int) floor(0.5 + 255.0 *
(0.30 * red + 0.59 * green + 0.11 * blue)));
Tcl_AppendResult(interp, buffer, (char *) NULL);
lineLen += 2;
if (lineLen > 60) {
lineLen = 0;
Tcl_AppendResult(interp, "\n", (char *) NULL);
}
}
break;
}
case 2: {
/*
* Finally, color mode. Here, just output the red, green,
* and blue values directly.
*/
for (xx = x; xx < x+width; xx++) {
TkImageGetColor(&cdata, XGetPixel(ximage, xx, yy),
&red, &green, &blue);
sprintf(buffer, "%02X%02X%02X",
(int) floor(0.5 + 255.0 * red),
(int) floor(0.5 + 255.0 * green),
(int) floor(0.5 + 255.0 * blue));
Tcl_AppendResult(interp, buffer, (char *) NULL);
lineLen += 6;
if (lineLen > 60) {
lineLen = 0;
Tcl_AppendResult(interp, "\n", (char *) NULL);
pTk/mTk/generic/tkCanvPs.c view on Meta::CPAN
}
switch (level) {
case 0: sprintf(buffer, ">\n} image\n"); break;
case 1: sprintf(buffer, ">\n} image\n"); break;
case 2: sprintf(buffer, ">\n} false 3 colorimage\n"); break;
}
Tcl_AppendResult(interp, buffer, (char *) NULL);
sprintf(buffer, "0 %d translate\n", rows);
Tcl_AppendResult(interp, buffer, (char *) NULL);
}
ckfree((char *) cdata.colors);
return TCL_OK;
}
/*
*--------------------------------------------------------------
*
* Tk_PostscriptPhoto --
*
* This procedure is called to output the contents of a
* photo image in Postscript, using a format appropriate for
pTk/mTk/tclGeneric/tclIOCmd.c view on Meta::CPAN
Tcl_RegisterChannel(interp, chan);
Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TcpAcceptCallbacksDeleteProc --
*
* Assocdata cleanup routine called when an interpreter is being
* deleted to set the interp field of all the accept callback records
* registered with the interpreter to NULL. This will prevent the
* interpreter from being used in the future to eval accept scripts.
*
* Results:
* None.
*
* Side effects:
* Deallocates memory and sets the interp field of all the accept
* callback records to NULL to prevent this interpreter from being
* used subsequently to eval accept scripts.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static void
TcpAcceptCallbacksDeleteProc(clientData, interp)
ClientData clientData; /* Data which was passed when the assocdata
* was registered. */
Tcl_Interp *interp; /* Interpreter being deleted - not used. */
{
Tcl_HashTable *hTblPtr;
Tcl_HashEntry *hPtr;
Tcl_HashSearch hSearch;
AcceptCallback *acceptCallbackPtr;
hTblPtr = (Tcl_HashTable *) clientData;
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
pTk/mTk/tclGeneric/tclTest.c view on Meta::CPAN
Tcl_Obj* tag; /* Tag for this event used to delete it */
} TestEvent;
/*
* Forward declarations for procedures defined later in this file:
*/
int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp));
static int AsyncHandlerProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int code));
static void CleanupTestSetassocdataTests _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp));
static void CmdDelProc1 _ANSI_ARGS_((ClientData clientData));
static void CmdDelProc2 _ANSI_ARGS_((ClientData clientData));
static int CmdProc1 _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, CONST char **argv));
static int CmdProc2 _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, CONST char **argv));
static void CmdTraceDeleteProc _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp,
int level, char *command, Tcl_CmdProc *cmdProc,
pTk/mTk/tclGeneric/tclTest.c view on Meta::CPAN
static int TestcmdtraceCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestchmodCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestcreatecommandCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestdcallCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestdelCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestdelassocdataCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestdstringCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestencodingObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestevalexObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestevalobjvObjCmd _ANSI_ARGS_((ClientData dummy,
pTk/mTk/tclGeneric/tclTest.c view on Meta::CPAN
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestexprstringCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestfileCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
static int TestfilelinkCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
static int TestfeventCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestgetassocdataCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestgetplatformCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestgetvarfullnameCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int TestinterpdeleteCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestlinkCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
pTk/mTk/tclGeneric/tclTest.c view on Meta::CPAN
Tcl_Obj *CONST objv[]));
static int TestregexpObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static void TestregexpXflags _ANSI_ARGS_((char *string,
int length, int *cflagsPtr, int *eflagsPtr));
static int TestsaveresultCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static void TestsaveresultFree _ANSI_ARGS_((char *blockPtr));
static int TestsetassocdataCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestsetCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestsetobjerrorcodeCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int TestopenfilechannelprocCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp, int argc,
CONST char **argv));
static int TestsetplatformCmd _ANSI_ARGS_((ClientData dummy,
pTk/mTk/tclGeneric/tclTest.c view on Meta::CPAN
Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testcmdtrace", TestcmdtraceCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testcreatecommand", TestcreatecommandCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testdel", TestdelCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testdelassocdata", TestdelassocdataCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_DStringInit(&dstring);
Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testencoding", TestencodingObjCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testevalex", TestevalexObjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testevalobjv", TestevalobjvObjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
pTk/mTk/tclGeneric/tclTest.c view on Meta::CPAN
Tcl_CreateObjCommand(interp, "testexprparser", TestexprparserObjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testfilelink", TestfilelinkCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testfile", TestfileCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testgetvarfullname",
TestgetvarfullnameCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testlink", TestlinkCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
pTk/mTk/tclGeneric/tclTest.c view on Meta::CPAN
Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testseterr", TestsetCmd,
(ClientData) TCL_LEAVE_ERR_MSG, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testsetobjerrorcode",
TestsetobjerrorcodeCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testnumutfchars",
TestNumUtfCharsCmd, (ClientData) 0,
pTk/mTk/tclGeneric/tclTest.c view on Meta::CPAN
Tcl_Eval(dPtr->interp, dPtr->deleteCmd);
Tcl_ResetResult(dPtr->interp);
ckfree(dPtr->deleteCmd);
ckfree((char *) dPtr);
}
/*
*----------------------------------------------------------------------
*
* TestdelassocdataCmd --
*
* This procedure implements the "testdelassocdata" command. It is used
* to test Tcl_DeleteAssocData.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Deletes an association between a key and associated data from an
* interpreter.
*
*----------------------------------------------------------------------
*/
static int
TestdelassocdataCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
" data_key\"", (char *) NULL);
return TCL_ERROR;
}
pTk/mTk/tclGeneric/tclTest.c view on Meta::CPAN
* be objv[3], and we don't own it
*/
Tcl_DecrRefCount(contents);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestgetassocdataCmd --
*
* This procedure implements the "testgetassocdata" command. It is
* used to test Tcl_GetAssocData.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestgetassocdataCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
char *res;
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
" data_key\"", (char *) NULL);
pTk/mTk/tclGeneric/tclTest.c view on Meta::CPAN
} else {
Tcl_SetResult(interp, "T3: wrong type for arg 1", TCL_STATIC);
result = TCL_ERROR;
}
return result;
}
/*
*----------------------------------------------------------------------
*
* CleanupTestSetassocdataTests --
*
* This function is called when an interpreter is deleted to clean
* up any data left over from running the testsetassocdata command.
*
* Results:
* None.
*
* Side effects:
* Releases storage.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static void
CleanupTestSetassocdataTests(clientData, interp)
ClientData clientData; /* Data to be released. */
Tcl_Interp *interp; /* Interpreter being deleted. */
{
ckfree((char *) clientData);
}
/*
*----------------------------------------------------------------------
*
* TestparserObjCmd --
pTk/mTk/tclGeneric/tclTest.c view on Meta::CPAN
}
}
*cflagsPtr = cflags;
*eflagsPtr = eflags;
}
/*
*----------------------------------------------------------------------
*
* TestsetassocdataCmd --
*
* This procedure implements the "testsetassocdata" command. It is used
* to test Tcl_SetAssocData.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Modifies or creates an association between a key and associated
* data for this interpreter.
*
*----------------------------------------------------------------------
*/
static int
TestsetassocdataCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
char *buf;
char *oldData;
Tcl_InterpDeleteProc *procPtr;
if (argc != 3) {
pTk/mTk/tclGeneric/tclTest.c view on Meta::CPAN
buf = ckalloc((unsigned) strlen(argv[2]) + 1);
strcpy(buf, argv[2]);
/*
* If we previously associated a malloced value with the variable,
* free it before associating a new value.
*/
oldData = (char *) Tcl_GetAssocData(interp, argv[1], &procPtr);
if ((oldData != NULL) && (procPtr == CleanupTestSetassocdataTests)) {
ckfree(oldData);
}
Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests,
(ClientData) buf);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestsetplatformCmd --
*
* This procedure implements the "testsetplatform" command. It is
}
#if 0
else
{
warn("ClientMessage '%s' for %s\n", key, Tk_PathName(tkwin));
}
#endif
}
int
LangEventCallback(cdata, interp, event, tkwin, keySym)
ClientData cdata;
Tcl_Interp *interp;
Tk_Window tkwin;
XEvent *event;
KeySym keySym;
{
dTHX;
SV *sv = (SV *) cdata;
int result = TCL_ERROR;
Tk_Window ewin = Tk_EventWindow(event);
#ifdef LEAK_CHECKING
hash_ptr *save = NULL;
long hwm = note_used(&save);
fprintf(stderr, "Event Entry count=%ld hwm=%ld\n", ec = sv_count, hwm);
#endif
Tcl_ResetResult(interp);
Lang_ClearErrorInfo(interp);
if (!SvOK(sv))
( run in 1.044 second using v1.01-cache-2.11-cpan-454fe037f31 )