EG: Some of the fancier features of modern *nix desktops aren't available in Tk by default. While the latest development addresses some of the issues (ttk/tile, Xft fonts), this is not the case of cursors, where they are still limited to bitmaps. Some people (see this post ) wants to use colored, animated cursors in their applications.
This bare-bones extension interfaces with the xcursor library allowing Tk developers use modern cursors on X11. It consist of three files: a .c file, a .tcl file for high level access and the pkgIndex.tcl library index.
/* file tkxcursor.c */
#include <tk.h>
#include <X11/Xcursor/Xcursor.h>
static int SetCursorCmd(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
int objc;
Tcl_Obj *objv[];
{
Tk_Window tkwin, mainw;
long xid;
Cursor cursor;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "window cursor");
return TCL_ERROR;
}
if (Tcl_GetLongFromObj(interp, objv[2], &xid) != TCL_OK)
return TCL_ERROR;
cursor = (Cursor) xid;
mainw = Tk_MainWindow(interp);
if (NULL == mainw)
return TCL_ERROR;
tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[1]), mainw);
if (NULL == tkwin)
return TCL_ERROR;
if (None == Tk_WindowId(tkwin))
Tk_MakeWindowExist(tkwin);
XDefineCursor(Tk_Display(tkwin), Tk_WindowId(tkwin), cursor);
return TCL_OK;
}
static int GetThemeCmd(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
int objc;
Tcl_Obj *objv[];
{
const char *theme;
Display *display = Tk_Display(Tk_MainWindow(interp));
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
theme = XcursorGetTheme(display);
Tcl_SetObjResult(interp, Tcl_NewStringObj(theme, -1));
return TCL_OK;
}
static int LoadCursorFromFileCmd(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
int objc;
Tcl_Obj *objv[];
{
Cursor cursor;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "filename");
return TCL_ERROR;
}
cursor = XcursorFilenameLoadCursor(Tk_Display(Tk_MainWindow(interp)),
Tcl_GetString(objv[1]));
if (cursor) {
Tcl_SetObjResult(interp, Tcl_NewLongObj((long)cursor));
return TCL_OK;
}
Tcl_AppendResult(interp, "Can't load cursor from file \"",
Tcl_GetString(objv[1]), "\"", NULL);
return TCL_ERROR;
}
static int FreeCursorCmd(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
int objc;
Tcl_Obj *objv[];
{
long xid;
Cursor cursor;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "cursorid");
return TCL_ERROR;
}
if (Tcl_GetLongFromObj(interp, objv[1], &xid) != TCL_OK)
return TCL_ERROR;
cursor = (Cursor) xid;
XFreeCursor(Tk_Display(Tk_MainWindow(interp)), cursor);
return TCL_OK;
}
static int IsARGBSupportedCmd(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
int objc;
Tcl_Obj *objv[];
{
Tk_Window tkwin = Tk_MainWindow(interp);
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(XcursorSupportsARGB(Tk_Display(tkwin))));
return TCL_OK;
}
int Xcursor_Init (interp)
Tcl_Interp * interp;
{
if (Tcl_InitStubs(interp, "8.5", 0) == NULL)
return TCL_ERROR;
if (Tk_InitStubs(interp, "8.5", 0) == NULL)
return TCL_ERROR;
if (Tcl_PkgProvide(interp, "xcursor", "0.1") == TCL_ERROR)
return TCL_ERROR;
/* these are "private" commands */
Tcl_CreateObjCommand(interp, "xcursor::DefineCursor", SetCursorCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "xcursor::LoadFromFile", LoadCursorFromFileCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "xcursor::FreeCursor", FreeCursorCmd, NULL, NULL);
/* these two are safe enough */
Tcl_CreateObjCommand(interp, "xcursor::argbsupported", IsARGBSupportedCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "xcursor::gettheme", GetThemeCmd, NULL, NULL);
return TCL_OK;
}# file tkxcursor.tcl
namespace eval xcursor {
variable cursors [dict create None 0]
}
proc xcursor::setcursor {window cursor} {
variable cursors
if {![winfo exists $window]} {
return -code error "bad window path name \"$window\""
}
if {![dict exists $cursors $cursor]} {
return -code error "cursor \"$cursor\" unknown"
}
DefineCursor $window [dict get $cursors $cursor]
}
proc xcursor::loadcursor {filename} {
variable cursors
if {![file exists $filename]} {
return -code error "could not read \"$filename\":\
no such file or directory"
}
set cursor [lindex [file split [file rootname $filename]] end]
if {[dict exists $cursors $cursor]} {
FreeCursor [dict get $cursors $cursor]
}
dict set cursors $cursor [LoadFromFile $filename]
return $cursor
}
proc xcursor::names {} {
variable cursors
return [dict keys $cursors]
}
proc xcursor::deletecursor {cursor} {
variable cursors
if {![dict exists $cursors $cursor]} {
return -code error "cursor \"$cursor\" unknown"
}
if {$cursor eq "None"} {
# don't delete the "None" cursor
return
}
FreeCursor [dict get $cursors $cursor]
set cursors [dict remove $cursors $cursor]
return
}# file pkgIndex.tcl
package ifneeded xcursor 0.1 [list apply {{dir} {
load [file join $dir libxcursor.so]
source [file join $dir tkxcursor.tcl]
}} $dir]Compile with
$ gcc -shared -fPIC -Wall -I/usr/local/include tkxcursor.c -o libxcursor.so \ -DUSE_TCL_STUBS -DUSE_TK_STUBS \ -L/usr/local/lib -ltkstub8.6 -ltclstub8.6 \ -L/usr/lib -lXcursor
In this case my Tcl (8.6) installation is on /usr/local/lib and the Xcursor library resides on /usr/lib. Adjust the paths and version numbers accordingly, compile and you're ready to go.
Simple usage:
$ tclsh8.6
% lappend auto_path .
/usr/local/lib/tcl8.6 /usr/local/lib .
% package require xcursor ; # also loads Tk
0.1
% xcursor::names
None
% xcursor::loadcursor ./PolarCursorTheme/cursors/watch ; # animated watch cursor
watch
% xcursor::setcursor . watch
% xcursor::names
None watch
% xcursor::setcursor . None ; # equivalent to [. configure -cursor {}]
% xcursor::deletecursor watch
% xcursor::names
None
% xcursor::argbsupported ; # does this display support ARGB cursors?
1
% xcursor::gettheme ; # default theme, in my case empty
%To set the default cursor theme see this wiki entry .
For cursor themes, see Gnome-Look or KDE-Look