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

Contents of /xlib-context.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

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

1 tpapp 13 (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 tpapp 15 ;; expose events
80 tpapp 13 ((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 tpapp 15 (xsynchronize display 1)
100 tpapp 13 (let ((saved-pointer pointer))
101     (setf pointer nil) ; invalidate first so it can't be used
102 tpapp 15 ;; (cairo_destroy saved-pointer)
103     )
104 tpapp 13 (xfreepixmap display pixmap)
105     (xdestroywindow display window)
106 tpapp 15 (xdestroywindow display signal-window)
107     (xclosedisplay display))))
108     ;; initialize
109 tpapp 13 (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 tpapp 17 (with-foreign-object (prot 'xatom)
156     (setf (mem-aref prot 'xatom) wm-delete-window)
157 tpapp 13 (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 tpapp 15 (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 tpapp 13 (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 tpapp 15 (xsync display-pointer 1))))
197 tpapp 13
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