tk-structs.lisp

   1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
   2 #|
   3
   4     Celtk -- Cells, Tcl, and Tk
   5
   6 Copyright (C) 2006 by Kenneth Tilton
   7
   8 This library is free software; you can redistribute it and/or
   9 modify it under the terms of the Lisp Lesser GNU Public License
  10  (http://opensource.franz.com/preamble.html), known as the LLGPL.
  11
  12 This library is distributed  WITHOUT ANY WARRANTY; without even
  13 the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  14
  15 See the Lisp Lesser GNU Public License for more details.
  16
  17 |#
  18
  19 (in-package :celtk)
  20
  21
  22 (defctype Window :unsigned-long) ;; <sigh> The XWindow pointer stored in the tkwin record
  23 (defctype Time :unsigned-long)
  24 (defctype Tk_Uid :string)
  25
  26 (defcstruct tk-fake-win
  27     "Used by macros to peek at tkwins (why use a fake window definition?)"
  28   (display :pointer)
  29   (dummy1 :pointer)
  30   (screen-num :int)
  31   (visual :pointer)
  32   (depth :int)
  33   (window Window)
  34   (dummy2 :pointer)
  35   (dummy3 :pointer)
  36   (parent-ptr Window)
  37   (dummy4 :pointer)
  38   (dummy5 :pointer)
  39   (pathName :string)
  40   ;;;    Tk_Uid nameUid;
  41   ;;;    Tk_Uid classUid;
  42   ;;;    XWindowChanges changes;
  43   ;;;    unsigned int dummy6;   /* dirtyChanges */
  44   ;;;    XSetWindowAttributes atts;
  45   ;;;    unsigned long dummy7;  /* dirtyAtts */
  46   ;;;    unsigned int flags;
  47   ;;;    char *dummy8;          /* handlerList */
  48   ;;;#ifdef TK_USE_INPUT_METHODS
  49   ;;;    XIC dummy9;                    /* inputContext */
  50   ;;;#endif /* TK_USE_INPUT_METHODS */
  51   ;;;    ClientData *dummy10;   /* tagPtr */
  52   ;;;    int dummy11;           /* numTags */
  53   ;;;    int dummy12;           /* optionLevel */
  54   ;;;    char *dummy13;         /* selHandlerList */
  55   ;;;    char *dummy14;         /* geomMgrPtr */
  56   ;;;    ClientData dummy15;            /* geomData */
  57   ;;;    int reqWidth, reqHeight;
  58   ;;;    int internalBorderLeft;
  59   ;;;    char *dummy16;         /* wmInfoPtr */
  60   ;;;    char *dummy17;         /* classProcPtr */
  61   ;;;    ClientData dummy18;            /* instanceData */
  62   ;;;    char *dummy19;         /* privatePtr */
  63   ;;;    int internalBorderRight;
  64   ;;;    int internalBorderTop;
  65   ;;;    int internalBorderBottom;
  66   ;;;    int minReqWidth;
  67   ;;;    int minReqHeight;
  68   )
  69
  70 (defun tkwin-pathname (tkwin)
  71   (foreign-slot-value tkwin 'tk-fake-win 'pathname))
  72
  73 (defun tkwin-window (tkwin)
  74   "Get the (different!) XWindow pointer from the tkwin data structure.
  75 Note that the Xwindow structure is not allocated straight away, not until
  76 (I guess) the XWindow server has gotten involved with the widget."
  77   (foreign-slot-value tkwin 'tk-fake-win 'window))
  78
  79 #|
  80 typedef struct {
  81     int type;
  82     unsigned long serial;   /* # of last request processed by server */
  83     Bool send_event;        /* True if this came from a SendEvent request */
  84     Display *display;       /* Display the event was read from */
  85     Window event;           /* Window on which event was requested. */
  86     Window root;            /* root window that the event occured on */
  87     Window subwindow;       /* child window */
  88     Time time;              /* milliseconds */
  89     int x, y;               /* pointer x, y coordinates in event window */
  90     int x_root, y_root;     /* coordinates relative to root */
  91     unsigned int state;     /* key or button mask */
  92     Tk_Uid name;            /* Name of virtual event. */
  93     Bool same_screen;       /* same screen flag */
  94     Tcl_Obj *user_data;     /* application-specific data reference; Tk will
  95                              * decrement the reference count *once* when it
  96                              * has finished processing the event. */
  97 } XVirtualEvent;
  98 |#
  99
 100 (defcstruct x-virtual-event
 101     "common event fields"
 102   (type :int)
 103   (serial :unsigned-long)
 104   (send-event :boolean)
 105   (display :pointer)
 106   (event-window Window)
 107   (root-window Window)
 108   (sub-window Window)
 109   (time Time)
 110   (x :int)
 111   (y :int)
 112   (x-root :int)
 113   (y-root :int)
 114   (state :unsigned-int)
 115   (name :string)
 116   (same-screen :boolean)
 117   (user-data :pointer)
 118   )
 119
 120 (defmacro xsv (slot-name xptr)
 121   `(foreign-slot-value ,xptr 'X-Virtual-Event ',slot-name))
 122
 123 (defun myx (xe)
 124   (xsv x xe))
 125 (defmacro xke (slot-name xptr)
 126   `(foreign-slot-value ,xptr 'x-key-event ',slot-name))
 127
 128 (export! xevent-type)
 129 (defun xevent-type (xe)
 130   (tk-event-type (xsv type xe)))
 131
 132 ;; -------------------------------------------
 133
 134 (defcstruct x-key-event
 135    "X key Event"
 136   (xke-header x-virtual-event)
 137   (trans-char-0 :char)
 138   (trans-char-1 :char)
 139   (trans-char-2 :char)
 140   (trans-char-3 :char))
 141
 142 (defcstruct x-button-event
 143     "common event fields"
 144   (type :int)
 145   (serial :unsigned-long)
 146   (send-event :boolean)
 147   (display :pointer)
 148   (event-window Window)
 149   (root-window Window)
 150   (sub-window Window)
 151   (time Time)
 152   (x :int)
 153   (y :int)
 154   (x-root :int)
 155   (y-root :int)
 156   (state :unsigned-int)
 157   (button :unsigned-int)
 158   (same-screen :boolean))
 159
 160 (defmacro xbe (slot-name xptr)
 161   `(foreign-slot-value ,xptr 'x-button-event ',slot-name))
 162
 163 (defun xbe-x (xbe) (xbe x xbe))
 164 (defun xbe-y (xbe) (xbe y xbe))
 165
 166 ;; --------------------------------------------
 167
 168 (defcenum tcl-event-flag-values
 169     (:tcl-dont-wait         2)
 170   (:tcl-window-events     4)
 171   (:tcl-file-events       8)
 172   (:tcl-timer-events     16)
 173   (:tcl-idle-events      32)
 174   (:tcl-all-events       -3))
 175
 176 (defcenum tcl-variable-related-flag
 177     "flags passed to getvar, setvar, tracevar, etc"
 178   (:tcl-global-only      1)
 179   (:tcl-namespace-only   2)
 180   (:tcl-append-value     4)
 181   (:tcl-list-element     8)
 182   (:tcl-trace-reads      #x10)
 183   (:tcl-trace-writes     #x20)
 184   (:tcl-trace-unsets     #x40)
 185   (:tcl-trace-destroyed  #x80)
 186   (:tcl-interp-destroyed #x100)
 187   (:tcl-leave-err-msg    #x200)
 188   (:tcl-trace-array      #x800)
 189   ;; required to support old variable/vdelete/vinfo traces */
 190   (:tcl-trace-old-style  #x1000)
 191   ;; indicate the semantics of the result of a trace */
 192   (:tcl-trace-result-dynamic #x8000)
 193   (:tcl-trace-result-object  #x10000))
 194
 195 (defun var-flags (&rest kws)
 196   (apply '+ (loop for kw in kws
 197                   collecting (foreign-enum-value 'tcl-variable-related-flag kw))))
 198
 199 (defcstruct Tcl_ChannelType
 200   (typeName         :string)
 201   (blockModeProc    :pointer)
 202   (closeProc        :pointer)
 203   (inputProc        :pointer)
 204   (outputProc       :pointer)
 205   (seekProc         :pointer)
 206   (setOptionProc    :pointer)
 207   (getOptionProc    :pointer)
 208   (watchChannelProc :pointer)
 209   (channelReadyProc :pointer)
 210   (getFileProc      :pointer))
 211