[Anyone have an updated url for the above? Is this something that critcl can compile?]
#include <sys/types.h>
#include <sys/stat.h>
#include <errno.h>
#include <stdlib.h>
#include <string.h>
#include <tcl.h>
#include <tk.h>
#include <X11/xpm.h>
#define OBJ_CMD_ARGS (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
typedef struct Tk_XpmInstance {
int refCount;
Display *dis;
Pixmap pix;
Pixmap pixMask;
Tk_Window tkwin;
Tk_ImageMaster master;
Tcl_Command cmd;
} Tk_XpmInstance;
static int GetPixmapSize (Display *dis, Pixmap p, int *width, int *height) {
Window root;
int x, y;
int bd;
int depth;
if (!XGetGeometry (dis, p, &root, &x, &y, width, height, &bd, &depth)) {
return 0;
}
return 1;
}
static void FreePixmapsIfNeeded (Tk_XpmInstance *xinst) {
/*An image may already have been loaded, so we should free the Pixmap's if so.*/
if (xinst->pix != None) {
XFreePixmap (xinst->dis, xinst->pix);
xinst->pix = None;
}
if (xinst->pixMask != None) {
XFreePixmap (xinst->dis, xinst->pixMask);
xinst->pixMask = None;
}
}
static int UpdateSize (Tcl_Interp *interp, Tk_XpmInstance *xinst) {
int width;
int height;
if (!GetPixmapSize (xinst->dis, xinst->pix, &width, &height)) {
Tcl_SetResult (interp, "unable to query pixmap size", TCL_STATIC);
return TCL_ERROR;
}
Tk_ImageChanged (xinst->master, 0, 0, 0, 0, width, height);
return TCL_OK;
}
static int Tk_XpmMakePixmapFromBuffer (Tcl_Interp *interp, char *buf, Tk_XpmInstance *xinst) {
Tk_Window tkmain;
Window xWin;
tkmain = Tk_MainWindow (interp);
Tk_MakeWindowExist (tkmain);
xWin = Tk_WindowId (tkmain);
if (XpmCreatePixmapFromBuffer (xinst->dis, xWin, buf, &xinst->pix, &xinst->pixMask, NULL)) {
Tcl_SetResult (interp, "bad xpm", TCL_STATIC);
xinst->pix = None;
xinst->pixMask = None;
return TCL_ERROR;
}
return TCL_OK;
}
static int Tk_XpmReadFileToPixmap (Tcl_Interp *interp, char *fileName, Tk_XpmInstance *xinst) {
Tcl_Channel chan = NULL;
Tcl_Obj *xpmBufObj;
struct stat statBuf;
xpmBufObj = Tcl_NewObj ();
if (Tcl_Stat (fileName, &statBuf)) {
Tcl_SetResult (interp, (char *) Tcl_ErrnoMsg (errno), TCL_VOLATILE);
return TCL_ERROR;
}
chan = Tcl_OpenFileChannel (interp, fileName, "r", 0);
if (chan == NULL) {
return TCL_ERROR;
}
if (Tcl_ReadChars (chan, xpmBufObj, statBuf.st_size, 0) != statBuf.st_size) {
Tcl_SetResult (interp, (char *) Tcl_ErrnoMsg (errno), TCL_VOLATILE);
return TCL_ERROR;
}
if (Tcl_Close (interp, chan) != TCL_OK) {
return TCL_ERROR;
}
FreePixmapsIfNeeded (xinst);
if (Tk_XpmMakePixmapFromBuffer (interp, Tcl_GetString (xpmBufObj), xinst) != TCL_OK) {
return TCL_ERROR;
}
Tcl_DecrRefCount (xpmBufObj);
return UpdateSize (interp, xinst);
}
static int Tk_XpmBufferToPixmap (Tcl_Interp *interp, char *xpmBuf, Tk_XpmInstance *xinst) {
FreePixmapsIfNeeded (xinst);
if (Tk_XpmMakePixmapFromBuffer (interp, xpmBuf, xinst) != TCL_OK) {
return TCL_ERROR;
}
return UpdateSize (interp, xinst);
}
static int Tk_XpmInstanceCmd OBJ_CMD_ARGS {
Tk_XpmInstance *xinst = (Tk_XpmInstance *) clientData;
char *subCmd = NULL;
int len = 0;
fprintf (stderr, "InstanceCmd\n");
if (objc != 3) {
Tcl_WrongNumArgs (interp, 1, objv, "file|data fileName|xpmData");
return TCL_ERROR;
}
subCmd = Tcl_GetStringFromObj (objv[1], &len);
if (strncmp (subCmd, "file", len) == 0) {
return Tk_XpmReadFileToPixmap (interp, Tcl_GetString (objv[2]), xinst);
} else if (strncmp (subCmd, "data", len) == 0) {
return Tk_XpmBufferToPixmap (interp, Tcl_GetString (objv[2]), xinst);
}
Tcl_SetResult (interp, "bad instance subcommand", TCL_STATIC);
return TCL_ERROR;
}
static void Tk_XpmFree (ClientData clientData, Display *dis) {
/*I don't do anything specific for widgets that use images,
*so AFAIK this doesn't need to do anything.
*/
/*fprintf (stderr, "FREE\n");*/
}
static void Tk_XpmDelete (ClientData clientData) {
Tk_XpmInstance *xinst = (Tk_XpmInstance *) clientData;
/*fprintf (stderr, "DELETE\n");*/
FreePixmapsIfNeeded (xinst);
if (xinst != NULL) {
Tcl_DeleteCommandFromToken (NULL, xinst->cmd);
Tcl_Free (clientData);
clientData = NULL;
}
}
static int Tk_XpmCreate (
Tcl_Interp *interp,
char *name,
int objc,
Tcl_Obj *CONST objv[],
Tk_ImageType *typePtr,
Tk_ImageMaster master,
ClientData *clientDataPtr
) {
Tk_XpmInstance *xinst = (Tk_XpmInstance *) Tcl_Alloc (sizeof (Tk_XpmInstance));
xinst->cmd = Tcl_CreateObjCommand (interp, name, Tk_XpmInstanceCmd, (ClientData) xinst, (Tcl_CmdDeleteProc *) NULL);
xinst->master = master;
xinst->dis = Tk_Display (Tk_MainWindow (interp));
xinst->pix = None;
xinst->pixMask = None;
Tk_ImageChanged (master, 0, 0, 1, 1, 1, 1);
*clientDataPtr = (ClientData) xinst;
return TCL_OK;
}
static ClientData Tk_XpmGet (Tk_Window tkwin, ClientData clientData) {
return clientData;
}
static void Tk_XpmDisplay (
ClientData clientData,
Display *dis,
Drawable d,
int x, int y,
int width, int height,
int destX, int destY
) {
Tk_XpmInstance *xinst = clientData;
int nScreen = 0;
GC copyGC;
XGCValues xgcval;
/*
fprintf (stderr, "x %d y %d width %d height %d destX %d destY %d\n", x, y, width, height, destX, destY);
*/
xgcval.clip_x_origin = destX;
xgcval.clip_y_origin = destY;
nScreen = DefaultScreen (dis);
copyGC = XCreateGC (dis, d, GCClipXOrigin | GCClipYOrigin, &xgcval);
if (xinst->pixMask != None) {
XSetClipMask (dis, copyGC, xinst->pixMask);
}
XCopyArea (dis, xinst->pix, d, copyGC, x, y, width, height, destX, destY);
XFreeGC (dis, copyGC);
XFlush (dis);
}
Tk_ImageType Tk_XpmImageType = {
"xpm",
Tk_XpmCreate,
Tk_XpmGet,
Tk_XpmDisplay,
Tk_XpmFree,
Tk_XpmDelete,
NULL,
(Tk_ImageType *) NULL
};
int Tk_Xpm_Init (Tcl_Interp *interp) {
Tk_CreateImageType (&Tk_XpmImageType);
return TCL_OK;
}You can download a demo here: [1] Any comments?
