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

Contents of /xlib-context.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 17 - (show annotations)
Sun Mar 23 22:58:24 2008 UTC (6 years, 1 month ago) by tpapp
File size: 7759 byte(s)
Several small changes:

- dependence on trivial-garbage for finalizer code
- fixes in examples/Makefile

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-xlib-context (width height &key
55 (display-name nil)
56 (window-name (next-xlib-context-name)))
57 (let ((display (xopendisplay (if display-name display-name (null-pointer)))))
58 (when (null-pointer-p display)
59 (error "couldn't open display ~a" display-name))
60 (let ((xlib-context (make-instance 'xlib-context
61 :display display
62 :width width
63 :height height)))
64 (flet ((event-loop ()
65 (with-slots (display (this-window window) signal-window
66 pixmap
67 wm-delete-window graphics-context)
68 xlib-context
69 (let ((wm-protocols (xinternatom display "WM_PROTOCOLS" 1)))
70 (with-foreign-object (xev :long 24)
71 (do ((got-close-signal nil))
72 (got-close-signal)
73 ;; get next event
74 (xnextevent display xev)
75 ;; decipher structure, at least partially
76 (with-foreign-slots ((type window serial) xev xanyevent)
77 ;; action based on event type
78 (cond
79 ;; expose events
80 ((and (= type 12) (= window this-window))
81 (refresh-xlib-context xlib-context))
82 ;; clientnotify event
83 ((= type 33)
84 (with-foreign-slots ((message-type data0) xev
85 xclientmessageevent)
86 (cond
87 ((or (and (= window signal-window)
88 (= data0 +destroy-message+))
89 (and (= window this-window)
90 (= message-type wm-protocols)
91 (= data0 wm-delete-window)))
92 (setf got-close-signal t))
93 ((and (= window signal-window)
94 (= data0 +refresh-message+))
95 (refresh-xlib-context xlib-context)))))))))))
96 ;; close down everything
97 (with-slots (display pixmap window signal-window pointer)
98 xlib-context
99 (xsynchronize display 1)
100 (let ((saved-pointer pointer))
101 (setf pointer nil) ; invalidate first so it can't be used
102 ;; (cairo_destroy saved-pointer)
103 )
104 (xfreepixmap display pixmap)
105 (xdestroywindow display window)
106 (xdestroywindow display signal-window)
107 (xclosedisplay display))))
108 ;; initialize
109 (xsynchronize display 1)
110 (let* ((screen (xdefaultscreen display))
111 (root (xdefaultrootwindow display))
112 (visual (xdefaultvisual display screen))
113 (depth (xdefaultdepth display screen))
114 (whitepixel (xwhitepixel display screen)))
115 (with-slots (window pixmap signal-window thread wm-delete-window
116 pointer graphics-context) xlib-context
117 ;; create signal window and window
118 (setf window
119 (create-window display root width height 'inputoutput visual
120 whitepixel
121 (logior exposuremask
122 structurenotifymask)
123 t))
124 (setf signal-window
125 (create-window display root 1 1 'inputonly visual
126 whitepixel 0 nil))
127 ;; create pixmap
128 (setf pixmap
129 (xcreatepixmap display window width height depth))
130 ;; create graphics-context
131 (setf graphics-context
132 (xcreategc display pixmap 0 (null-pointer)))
133 ;; set size hints on window (most window managers will respect this)
134 (let ((hints (xallocsizehints)))
135 (with-foreign-slots ((flags x y min-width min-height
136 max-width max-height)
137 hints
138 xsizehints)
139 ;; we only set the first four values because old WM's might
140 ;; get confused if we don't, they should be ignored
141 (setf flags (logior pminsize pmaxsize)
142 x 0
143 y 0
144 (foreign-slot-value hints 'xsizehints 'width) width
145 (foreign-slot-value hints 'xsizehints 'height) height
146 min-width width
147 max-width width
148 min-height height
149 max-height height)
150 (xsetwmnormalhints display window hints)
151 (xfree hints)))
152 ;; intern atom for window closing, set protocol on window
153 (setf wm-delete-window
154 (xinternatom display "WM_DELETE_WINDOW" 1))
155 (with-foreign-object (prot 'xatom)
156 (setf (mem-aref prot 'xatom) wm-delete-window)
157 (xsetwmprotocols display window prot 1))
158 ;; store name
159 (xstorename display window window-name)
160 ;; create cairo context
161 (let ((surface (cairo_xlib_surface_create display pixmap visual
162 width height)))
163 (setf pointer (cairo_create surface))
164 ;; !!! error checking
165 (cairo_surface_destroy surface))
166 ;; map window
167 (xmapwindow display window)
168 ;; end of synchronizing
169 (xsynchronize display 0)
170 ;; start thread
171 (setf thread
172 (start-thread
173 #'event-loop
174 (format nil "thread for display ~a" display-name))))))
175 ;; return context
176 xlib-context)))
177
178
179 (defun send-message-to-signal-window (xlib-context message)
180 "Send the desired message to the context window."
181 (with-slots (pointer (display-pointer display) signal-window) xlib-context
182 (unless pointer
183 (warn "context is not active, can't send message to window")
184 (return-from send-message-to-signal-window))
185 (with-foreign-object (xev :long 24)
186 (with-foreign-slots
187 ((type display window message-type format data0)
188 xev xclientmessageevent)
189 (setf type 33) ; clientnotify
190 (setf display display-pointer)
191 (setf window signal-window)
192 (setf message-type 0)
193 (setf format 32)
194 (setf data0 message)
195 (xsendevent display-pointer signal-window 0 0 xev))
196 (xsync display-pointer 1))))
197
198 (defmethod destroy ((object xlib-context))
199 (send-message-to-signal-window object +destroy-message+))
200
201 (defmethod sync ((object xlib-context))
202 (when (zerop (sync-counter object))
203 (send-message-to-signal-window object +refresh-message+)))
204
205 (defmethod sync-lock ((object xlib-context))
206 (incf (sync-counter object)))
207
208 (defmethod sync-unlock ((object xlib-context))
209 (with-slots (sync-counter) object
210 (when (plusp sync-counter)
211 (decf sync-counter)))
212 (sync object))
213
214 (defmethod sync-reset ((object xlib-context))
215 (setf (sync-counter object) 0)
216 (sync object))
217

  ViewVC Help
Powered by ViewVC 1.1.5