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

Contents of /xlib.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 17 - (show 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 (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 (defctype cursor xid)
17 (defctype colormap xid)
18 (defctype graphics-context xid)
19 (defctype visual :pointer)
20 (defctype xatom :unsigned-long)
21 (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 (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 (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
229 (defcfun ("XSetGraphicsExposures" xsetgraphicsexposures) :int
230 (display display)
231 (graphics-context graphics-context)
232 (graphics-exposures bool))
233
234
235 ;; synchronization & threads
236
237 (defcfun ("XInitThreads" xinitthreads) :int)
238
239 (defcfun ("XLockDisplay" xlockdisplay) :int
240 (display display))
241
242 (defcfun ("XUnlockDisplay" xunlockdisplay) :int
243 (display display))
244
245 (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 (defcfun ("XInternAtom" xinternatom) xatom
259 (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 (message-type xatom)
308 (format :int)
309 ;; we only use first field, union of message data is not included
310 (data0 :unsigned-long))
311
312 (defcstruct xvisibilityevent
313 (type :int)
314 (serial :unsigned-long)
315 (send-event bool)
316 (display display)
317 (window window)
318 (state :int))
319
320 (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 ;; image manipulation
391
392 (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 ;; call xinitthreads
433
434 (xinitthreads)
435
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