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

Contents of /xlib.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: 11688 byte(s)
Several small changes:

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

1 tpapp 11 (in-package :cl-cairo2)
2    
3     ;;;;
4     ;;;; a limited interface to certain Xlib functions
5     ;;;;
6    
7     (load-foreign-library "libX11.so")
8    
9     ;;;; types
10    
11     (defctype display :pointer)
12     (defctype xid :unsigned-long) ; X Id type
13     (defctype drawable xid)
14     (defctype window xid)
15     (defctype pixmap xid)
16 tpapp 13 (defctype cursor xid)
17     (defctype colormap xid)
18 tpapp 11 (defctype graphics-context xid)
19     (defctype visual :pointer)
20 tpapp 17 (defctype xatom :unsigned-long)
21 tpapp 11 (defctype bool :int)
22    
23     ;; constants
24    
25     (defmacro define-bitmask-constants (&body name-power-pairs)
26     "Define a list of constants from name-value pairs, raising 2 to
27     the power value."
28     (labels ((dbc (pairs)
29     (case (length pairs)
30     (0 nil)
31     (1 (error "no power after ~a" (car name-power-pairs)))
32     (t (destructuring-bind (name power &rest rest) pairs
33     `((defconstant ,name (expt 2 ,power))
34     ,@(dbc rest)))))))
35     `(progn
36     ,@(dbc name-power-pairs))))
37    
38     (defconstant noeventmask 0)
39     (define-bitmask-constants
40     keypressmask 0
41     keyreleasemask 1
42     buttonpressmask 2
43     buttonreleasemask 3
44     enterwindowmask 4
45     leavewindowmask 5
46     pointermotionmask 6
47     pointermotionhintmask 7
48     button1motionmask 8
49     button2motionmask 9
50     button3motionmask 10
51     button4motionmask 11
52     button5motionmask 12
53     buttonmotionmask 13
54     keymapstatemask 14
55     exposuremask 15
56     visibilitychangemask 16
57     structurenotifymask 17
58     resizeredirectmask 18
59     substructurenotifymask 19
60     substructureredirectmask 20
61     focuschangemask 21
62     propertychangemask 23
63     colormapchangemask 23
64     ownergrabbuttonmask 24)
65    
66    
67     ;;;; error code handling
68     (defmacro check-status (call)
69     "Check the return calue of call, if nonzero, display an error message."
70     (with-unique-names (status)
71     `(let ((,status ,call))
72     (if (zerop ,status)
73     (values)
74     (error "operations ~a returned status (error) ~a" ',call ,status)))))
75    
76     ;;;; display operations
77    
78     (defcfun ("XOpenDisplay" xopendisplay) display
79     (display-name :string))
80    
81     (defcfun ("XCloseDisplay" xclosedisplay) :int
82     (display display))
83    
84    
85     ;;;; defaults for the X11 display & screen
86    
87     (defcfun ("XDefaultDepth" xdefaultdepth) :int
88     (display display)
89     (screen-number :int))
90    
91     (defcfun ("XDefaultRootWindow" xdefaultrootwindow) window
92     (display display))
93    
94     (defcfun ("XDefaultScreen" xdefaultscreen) :int
95     (display display))
96    
97     (defcfun ("XDefaultVisual" xdefaultvisual) visual
98     (display display)
99     (screen-number :int))
100    
101     (defcfun ("XBlackPixel" xblackpixel) :unsigned-long
102     (display display)
103     (screen-number :int))
104    
105     (defcfun ("XWhitePixel" xwhitepixel) :unsigned-long
106     (display display)
107     (screen-number :int))
108    
109    
110     ;;;; graphics contexts
111    
112     (defcfun ("XDefaultGC" xdefaultgc) graphics-context
113     (display display)
114     (screen-number :int))
115    
116     (defcfun ("XCreateGC" xcreategc) graphics-context
117     (display display)
118     (drawable drawable)
119     (valuemask :unsigned-long)
120     (xgcvalues :pointer))
121    
122     (defcfun ("XFreeGC" xfreegc) :int
123     (display display)
124     (graphics-context graphics-context))
125    
126     ;;;; window and pixmap management
127    
128     (defcfun ("XMapWindow" xmapwindow) :int
129     (display display)
130     (window window))
131    
132     (defcfun ("XCreateSimpleWindow" xcreatesimplewindow) window
133     (display display)
134     (parent window)
135     (x :int)
136     (y :int)
137     (width :unsigned-int)
138     (height :unsigned-int)
139     (border-width :unsigned-int)
140     (border :unsigned-long)
141     (background :unsigned-long))
142    
143 tpapp 13 (defcfun ("XCreateWindow" xcreatewindow) window
144     (display display)
145     (parent window)
146     (x :int)
147     (y :int)
148     (width :unsigned-int)
149     (height :unsigned-int)
150     (border-width :unsigned-int)
151     (depth :int)
152     (class :unsigned-int)
153     (visual visual)
154     (valuemask :unsigned-long)
155     (attributes :pointer))
156    
157     (defcstruct xsetwindowattributes
158     (background-pixmap pixmap)
159     (background-pixel :unsigned-long)
160     (border-pixmap pixmap)
161     (border-pixel :unsigned-long)
162     (bit-gravity :int)
163     (win-gravity :int)
164     (backing-store :int)
165     (backing-planes :unsigned-long)
166     (backing-pixel :unsigned-long)
167     (save-under bool)
168     (event-mask :long)
169     (do-not-propagate_mask :long)
170     (override-redirect bool)
171     (colormap colormap)
172     (cursor cursor))
173    
174     (define-bitmask-constants
175     CWBackPixmap 0
176     CWBackPixel 1
177     CWBorderPixmap 2
178     CWBorderPixel 3
179     CWBitGravity 4
180     CWWinGravity 5
181     CWBackingStore 6
182     CWBackingPlanes 7
183     CWBackingPixel 8
184     CWOverrideRedirect 9
185     CWSaveUnder 10
186     CWEventMask 11
187     CWDontPropagate 12
188     CWColormap 13
189     CWCursor 14)
190    
191     (defcfun ("XChangeWindowAttributes" xchangewindowattributes) :int
192     (display display)
193     (window window)
194     (valuemask :unsigned-long)
195     (attributes :pointer))
196    
197 tpapp 11 (defcfun ("XDestroyWindow" xdestroywindow) :int
198     (display display)
199     (window window))
200    
201     (defcfun ("XCreatePixmap" xcreatepixmap) pixmap
202     (display display)
203     (drawable drawable)
204     (width :unsigned-int)
205     (height :unsigned-int)
206     (depth :unsigned-int))
207    
208     (defcfun ("XFreePixmap" xfreepixmap) :int
209     (display display)
210     (pixmap pixmap))
211    
212     (defcfun ("XSelectInput" xselectinput) :int
213     (display display)
214     (window window)
215     (event-mask :long))
216    
217     (defcfun ("XCopyArea" xcopyarea) :int
218     (display display)
219     (source drawable)
220     (destination drawable)
221     (graphics-context graphics-context)
222     (source-x :int)
223     (source-y :int)
224     (width :unsigned-int)
225     (height :unsigned-int)
226     (destination-x :int)
227     (destination-y :int))
228 tpapp 13
229     (defcfun ("XSetGraphicsExposures" xsetgraphicsexposures) :int
230     (display display)
231     (graphics-context graphics-context)
232     (graphics-exposures bool))
233    
234 tpapp 11
235     ;; synchronization & threads
236    
237     (defcfun ("XInitThreads" xinitthreads) :int)
238    
239 tpapp 13 (defcfun ("XLockDisplay" xlockdisplay) :int
240     (display display))
241    
242     (defcfun ("XUnlockDisplay" xunlockdisplay) :int
243     (display display))
244    
245 tpapp 11 (defcfun ("XSynchronize" xsynchronize) :int
246     (display display)
247     (onoff :int))
248    
249     (defcfun ("XFlush" xflush) :int
250     (display display))
251    
252     (defcfun ("XSync" xsync) :int
253     (display display)
254     (discard :int))
255    
256     ;; atoms & protocols
257    
258 tpapp 17 (defcfun ("XInternAtom" xinternatom) xatom
259 tpapp 11 (display display)
260     (atom-name :string)
261     (only-if-exists :int))
262    
263     (defcfun ("XSetWMProtocols" xsetwmprotocols) :int
264     (display display)
265     (window window)
266     (protocols :pointer)
267     (count :int))
268    
269    
270     ;; events
271    
272     (defcstruct xanyevent
273     (type :int)
274     (serial :unsigned-long)
275     (send-event bool)
276     (display display)
277     (window window))
278    
279     (defcstruct xexposeevent
280     (type :int)
281     (serial :unsigned-long)
282     (send-event bool)
283     (display display)
284     (drawable drawable)
285     (x :int)
286     (y :int)
287     (width :int)
288     (height :int)
289     (count :int)
290     (major-code :int)
291     (minor-code :int))
292    
293     (defcstruct xdestroywindowevent
294     (type :int)
295     (serial :unsigned-long)
296     (send-event bool)
297     (display display)
298     (event window)
299     (window window))
300    
301     (defcstruct xclientmessageevent
302     (type :int)
303     (serial :unsigned-long)
304     (send-event bool)
305     (display display)
306     (window window)
307 tpapp 17 (message-type xatom)
308 tpapp 11 (format :int)
309     ;; we only use first field, union of message data is not included
310     (data0 :unsigned-long))
311    
312 tpapp 13 (defcstruct xvisibilityevent
313     (type :int)
314     (serial :unsigned-long)
315     (send-event bool)
316     (display display)
317     (window window)
318     (state :int))
319    
320 tpapp 11 (defcfun ("XNextEvent" xnextevent) :int
321     (display display)
322     (event-return :pointer))
323    
324     (defcfun ("XSendEvent" xsendevent) :int
325     (display display)
326     (window window)
327     (propagate bool)
328     (event-mask :long)
329     (xevent :pointer))
330    
331     ;; hints & misc
332    
333     (defcstruct xsizehints
334     (flags :long) ; marks which fields in this structure are defined
335     (x :int) ; Obsolete
336     (y :int) ; Obsolete
337     (width :int) ; Obsolete
338     (height :int) ; Obsolete
339     (min-width :int)
340     (min-height :int)
341     (max-width :int)
342     (max-height :int)
343     (min-aspect-x :int) ; numerator
344     (min-aspect-y :int) ; denominator
345     (max-aspect-x :int) ; numerator
346     (max-aspect-y :int) ; denominator
347     (base-width :int)
348     (base_height :int)
349     (win_gravity :int))
350    
351     (define-bitmask-constants
352     USPosition 0
353     USSize 1
354     PPosition 2
355     PSize 3
356     PMinSize 4
357     PMaxSize 5
358     PResizeInc 6
359     PAspect 7
360     PBaseSize 8
361     PWinGravity 9)
362    
363     (defcfun ("XAllocSizeHints" xallocsizehints) :pointer)
364    
365     (defcfun ("XSetWMNormalHints" xsetwmnormalhints) :void
366     (display display)
367     (window window)
368     (hints :pointer))
369    
370     (defcfun ("XStoreName" xstorename) :int
371     (display display)
372     (window window)
373     (window-name :string))
374    
375     (defcfun ("XFree" xfree) :int
376     (data :pointer))
377    
378    
379     ;; extensions
380    
381     (defcfun ("XAddExtension" xaddextension) :pointer
382     (display display))
383    
384     (defcstruct xextcodes
385     (extensions :int)
386     (major-opcode :int)
387     (first-event :int)
388     (first-error :int))
389    
390 tpapp 15 ;; image manipulation
391 tpapp 11
392 tpapp 15 (cffi:defcstruct XImage
393     (width :int)
394     (height :int)
395     (xoffset :int)
396     (format :int)
397     (data :pointer)
398     (byte-order :int)
399     (bitmap-unit :int)
400     (bitmap-bit-order :int)
401     (bitmap-pad :int)
402     (depth :int)
403     (bytes-per-line :int)
404     (bits-per-pixel :int)
405     (red-mask :unsigned-long)
406     (green-mask :unsigned-long)
407     (blue-mask :unsigned-long)
408     (obdata :pointer)
409     ;; funcs
410     (create-image :pointer)
411     (destroy-image :pointer)
412     (get-pixel :pointer)
413     (put-pixel :pointer)
414     (sub-image :pointer)
415     (add-pixel :pointer))
416    
417     (defcfun ("XInitImage" xinitimage) :int
418     (ximage :pointer))
419    
420     (defcfun ("XPutImage" xputimage) :int
421     (display display)
422     (drawable drawable)
423     (graphics-context graphics-context)
424     (ximage :pointer)
425     (src-x :int)
426     (src-y :int)
427     (dest-x :int)
428     (dest-y :int)
429     (width :unsigned-int)
430     (height :unsigned-int))
431    
432 tpapp 11 ;; call xinitthreads
433    
434     (xinitthreads)
435 tpapp 15
436    
437     ;; various higher level functions
438    
439     (defun set-window-size-hints (display window
440     min-window-width max-window-width
441     min-window-height max-window-height)
442     ;; set size hints on window (most window managers will respect this)
443     (let ((hints (xallocsizehints)))
444     (with-foreign-slots ((flags x y min-width min-height
445     max-width max-height)
446     hints
447     xsizehints)
448     ;; we only set the first four values because old WM's might
449     ;; get confused if we don't, they should be ignored
450     (setf flags (logior pminsize pmaxsize)
451     x 0
452     y 0
453     ;; we don't need to set the following, but some WMs go
454     ;; crazy if we don't
455     (foreign-slot-value hints 'xsizehints 'width) max-window-width
456     (foreign-slot-value hints 'xsizehints 'height) max-window-height
457     ;; set desired min/max width/height
458     min-width min-window-width
459     max-width max-window-width
460     min-height min-window-height
461     max-height max-window-height)
462     (xsetwmnormalhints display window hints)
463     (xfree hints))))
464    
465     (defun create-window (display parent width height class visual background-pixel
466     event-mask &optional (backing-store t))
467     "Create an x11 window, placed at 0 0, with the given attributes.
468     For internal use in the cl-cairo2 package."
469     ;; call xcreatewindow with attributes
470     (with-foreign-object (attributes 'xsetwindowattributes)
471     (setf (foreign-slot-value attributes 'xsetwindowattributes 'event-mask)
472     event-mask
473     (foreign-slot-value attributes 'xsetwindowattributes 'background-pixel)
474     background-pixel
475     (foreign-slot-value attributes 'xsetwindowattributes 'backing-store)
476     (if backing-store 1 0))
477     (xcreatewindow display parent 0 0 width height
478     0 ; zero border width
479     0 ; depth - copy from parent
480     (ecase class
481     (copyfromparent 0)
482     (inputoutput 1)
483     (inputonly 2)) ; class
484     visual
485     (if (eq class 'inputonly)
486     cweventmask
487     (logior cwbackpixel cwbackingstore cweventmask))
488     attributes)))

  ViewVC Help
Powered by ViewVC 1.1.5