Updated 2017-11-02 04:04:51 by SEH

GPS Sep 27, 2002 : I was curious the other day about how Tk's image functions/procedures work at the C level. I spent two days off-and-on working on a little extension for displaying Xpm images. Tk makes this much simpler than I thought it would. The implementation below even handles transparency properly.


[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?