/[cl-cairo2]/xlib-context.lisp
ViewVC logotype

Contents of /xlib-context.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 13 - (show annotations)
Wed Aug 22 16:13:14 2007 UTC (6 years, 7 months ago) by tpapp
File size: 8571 byte(s)
another major revamping of X11 code, also put exported symbols in package.lisp where they belong
1 (in-package :cl-cairo2)
2
3 ;; constants for communicating with the signal window
4 (defconstant +destroy-message+ 4072) ; just some random constant
5 (defconstant +refresh-message+ 2495) ; ditto
6
7 (defvar *xlib-context-count* 0 "window counter for autogenerating names")
8
9 (defun next-xlib-context-name ()
10 "Return an autogenerated window name using *xlib-context-count*."
11 (format nil "cl-cairo2 ~a" (incf *xlib-context-count*)))
12
13 ;; code to make threads, please extend with your own Lisp if needed
14 ;; testing is welcome, I only tested cmucl and sbcl
15 (defun start-thread (function name)
16 #+allegro (mp:process-run-function name function)
17 #+armedbear (ext:make-thread function :name name)
18 #+cmu (mp:make-process function :name name)
19 #+lispworks (mp:process-run-function name nil function)
20 #+openmcl (ccl:process-run-function name function)
21 #+sbcl (sb-thread:make-thread function :name name))
22
23 ;; we create this definition manually, SWIG just messes things up
24 (defcfun ("cairo_xlib_surface_create" cairo_xlib_surface_create) cairo_surface_t
25 (display display)
26 (drawable drawable)
27 (visual visual)
28 (width :int)
29 (height :int))
30
31 ;; The class for an x11 context. Each context has a separate display
32 ;; queue, window and an event loop in a separate thread. Once the
33 ;; event loop is started, communication with the thread is done via
34 ;; X11 ClientNotify events (see wacky constants above).
35
36 (defclass xlib-context (context)
37 ((display :initarg :display)
38 (wm-delete-window)
39 (window)
40 (signal-window)
41 (pixmap)
42 (graphics-context)
43 (thread)
44 (sync-counter :initform 0 :accessor sync-counter)))
45
46 (defun refresh-xlib-context (xlib-context)
47 "Copy the contents of the pixmap to the window. This function is
48 meant for internal use in the cl-cairo2 package."
49 (with-slots (display width height window pixmap graphics-context) xlib-context
50 (xcopyarea display pixmap window graphics-context
51 0 0 width height 0 0)
52 (xsync display 1)))
53
54 (defun create-window (display parent width height class visual background-pixel
55 event-mask &optional (backing-store t))
56 "Create an x11 window, placed at 0 0, with the given attributes.
57 For internal use in the cl-cairo2 package."
58 ;; call xcreatewindow with attributes
59 (with-foreign-object (attributes 'xsetwindowattributes)
60 (setf (foreign-slot-value attributes 'xsetwindowattributes 'event-mask)
61 event-mask
62 (foreign-slot-value attributes 'xsetwindowattributes 'background-pixel)
63 background-pixel
64 (foreign-slot-value attributes 'xsetwindowattributes 'backing-store)
65 (if backing-store 1 0))
66 (xcreatewindow display parent 0 0 width height
67 0 ; zero border width
68 0 ; depth - copy from parent
69 (ecase class
70 (copyfromparent 0)
71 (inputoutput 1)
72 (inputonly 2)) ; class
73 visual
74 (if (eq class 'inputonly)
75 cweventmask
76 (logior cwbackpixel cwbackingstore cweventmask))
77 attributes)))
78
79 (defun create-xlib-context (width height &key
80 (display-name nil)
81 (window-name (next-xlib-context-name)))
82 (let ((display (xopendisplay (if display-name display-name (null-pointer)))))
83 (when (null-pointer-p display)
84 (error "couldn't open display ~a" display-name))
85 (let ((xlib-context (make-instance 'xlib-context
86 :display display
87 :width width
88 :height height)))
89 (flet ((event-loop ()
90 (with-slots (display (this-window window) signal-window
91 pixmap
92 wm-delete-window graphics-context)
93 xlib-context
94 (let ((wm-protocols (xinternatom display "WM_PROTOCOLS" 1)))
95 (with-foreign-object (xev :long 24)
96 (do ((got-close-signal nil))
97 (got-close-signal)
98 ;; get next event
99 (xnextevent display xev)
100 ;; decipher structure, at least partially
101 (with-foreign-slots ((type window serial) xev xanyevent)
102 ;; action based on event type
103 (cond
104 ;; expose and configurenotify events
105 ((and (= type 12) (= window this-window))
106 (refresh-xlib-context xlib-context))
107 ;; clientnotify event
108 ((= type 33)
109 (with-foreign-slots ((message-type data0) xev
110 xclientmessageevent)
111 (cond
112 ((or (and (= window signal-window)
113 (= data0 +destroy-message+))
114 (and (= window this-window)
115 (= message-type wm-protocols)
116 (= data0 wm-delete-window)))
117 (setf got-close-signal t))
118 ((and (= window signal-window)
119 (= data0 +refresh-message+))
120 (refresh-xlib-context xlib-context)))))))))))
121 ;; close down everything
122 (with-slots (display pixmap window signal-window pointer)
123 xlib-context
124 (let ((saved-pointer pointer))
125 (setf pointer nil) ; invalidate first so it can't be used
126 (cairo_destroy saved-pointer))
127 (xfreepixmap display pixmap)
128 (xdestroywindow display window)
129 (xdestroywindow display signal-window)
130 (xclosedisplay display))))
131 ;; initialize
132 (xsynchronize display 1)
133 (let* ((screen (xdefaultscreen display))
134 (root (xdefaultrootwindow display))
135 (visual (xdefaultvisual display screen))
136 (depth (xdefaultdepth display screen))
137 (whitepixel (xwhitepixel display screen)))
138 (with-slots (window pixmap signal-window thread wm-delete-window
139 pointer graphics-context) xlib-context
140 ;; create signal window and window
141 (setf window
142 (create-window display root width height 'inputoutput visual
143 whitepixel
144 (logior exposuremask
145 structurenotifymask)
146 t))
147 (setf signal-window
148 (create-window display root 1 1 'inputonly visual
149 whitepixel 0 nil))
150 ;; create pixmap
151 (setf pixmap
152 (xcreatepixmap display window width height depth))
153 ;; create graphics-context
154 (setf graphics-context
155 (xcreategc display pixmap 0 (null-pointer)))
156 ;; set size hints on window (most window managers will respect this)
157 (let ((hints (xallocsizehints)))
158 (with-foreign-slots ((flags x y min-width min-height
159 max-width max-height)
160 hints
161 xsizehints)
162 ;; we only set the first four values because old WM's might
163 ;; get confused if we don't, they should be ignored
164 (setf flags (logior pminsize pmaxsize)
165 x 0
166 y 0
167 (foreign-slot-value hints 'xsizehints 'width) width
168 (foreign-slot-value hints 'xsizehints 'height) height
169 min-width width
170 max-width width
171 min-height height
172 max-height height)
173 (xsetwmnormalhints display window hints)
174 (xfree hints)))
175 ;; intern atom for window closing, set protocol on window
176 (setf wm-delete-window
177 (xinternatom display "WM_DELETE_WINDOW" 1))
178 (with-foreign-object (prot 'atom)
179 (setf (mem-aref prot 'atom) wm-delete-window)
180 (xsetwmprotocols display window prot 1))
181 ;; store name
182 (xstorename display window window-name)
183 ;; create cairo context
184 (let ((surface (cairo_xlib_surface_create display pixmap visual
185 width height)))
186 (setf pointer (cairo_create surface))
187 ;; !!! error checking
188 (cairo_surface_destroy surface))
189 ;; map window
190 (xmapwindow display window)
191 ;; end of synchronizing
192 (xsynchronize display 0)
193 ;; start thread
194 (setf thread
195 (start-thread
196 #'event-loop
197 (format nil "thread for display ~a" display-name))))))
198 ;; return context
199 xlib-context)))
200
201
202 (defun send-message-to-signal-window (xlib-context message)
203 "Send the desired message to the context window."
204 (with-slots ((display-pointer display) signal-window) xlib-context
205 (with-foreign-object (xev :long 24)
206 (with-foreign-slots
207 ((type display window message-type format data0)
208 xev xclientmessageevent)
209 (setf type 33) ; clientnotify
210 (setf display display-pointer)
211 (setf window signal-window)
212 (setf message-type 0)
213 (setf format 32)
214 (setf data0 message)
215 (xsendevent display-pointer signal-window 0 0 xev))
216 (xflush display-pointer))))
217
218
219 (defmethod destroy ((object xlib-context))
220 (send-message-to-signal-window object +destroy-message+))
221
222 (defmethod sync ((object xlib-context))
223 (when (zerop (sync-counter object))
224 (send-message-to-signal-window object +refresh-message+)))
225
226 (defmethod sync-lock ((object xlib-context))
227 (incf (sync-counter object)))
228
229 (defmethod sync-unlock ((object xlib-context))
230 (with-slots (sync-counter) object
231 (when (plusp sync-counter)
232 (decf sync-counter)))
233 (sync object))
234
235 (defmethod sync-reset ((object xlib-context))
236 (setf (sync-counter object) 0)
237 (sync object))
238

  ViewVC Help
Powered by ViewVC 1.1.5