/[cmucl]/src/clx/requests.lisp
ViewVC logotype

Contents of /src/clx/requests.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8.14.1 - (hide annotations)
Wed Jun 17 15:46:26 2009 UTC (4 years, 10 months ago) by rtoy
Branch: portable-clx-branch
CVS Tags: portable-clx-import-2009-06-16
Changes since 1.8: +0 -3 lines
Import portable clx version from Christophe Rhodes darcs repository as
of 2009-06-16.

This is an exact copy of the code.  It is intended updates of
portable-clx go on the portable-clx-branch and should be merged to the
main branch as needed.  This should make it easier to do any
CMUCL-specific changes that aren't in portable-clx.

I chose not to import the files in the clx/manual directory.
Everything else is imported.  (Should the manual be imported too?)
1 ram 1.1 ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
2    
3     ;;;
4     ;;; TEXAS INSTRUMENTS INCORPORATED
5     ;;; P.O. BOX 2909
6     ;;; AUSTIN, TEXAS 78769
7     ;;;
8     ;;; Copyright (C) 1987 Texas Instruments Incorporated.
9     ;;;
10     ;;; Permission is granted to any individual or institution to use, copy, modify,
11     ;;; and distribute this software, provided that this complete copyright and
12     ;;; permission notice is maintained, intact, in all copies and supporting
13     ;;; documentation.
14     ;;;
15     ;;; Texas Instruments Incorporated provides this software "as is" without
16     ;;; express or implied warranty.
17     ;;;
18 fgilham 1.8
19 ram 1.1 (in-package :xlib)
20    
21     (defun create-window (&key
22 ram 1.2 window
23 ram 1.1 (parent (required-arg parent))
24     (x (required-arg x))
25     (y (required-arg y))
26     (width (required-arg width))
27     (height (required-arg height))
28     (depth 0) (border-width 0)
29     (class :copy) (visual :copy)
30     background border
31     bit-gravity gravity
32     backing-store backing-planes backing-pixel save-under
33     event-mask do-not-propagate-mask override-redirect
34     colormap cursor)
35     ;; Display is obtained from parent. Only non-nil attributes are passed on in
36     ;; the request: the function makes no assumptions about what the actual protocol
37     ;; defaults are. Width and height are the inside size, excluding border.
38 ram 1.2 (declare (type (or null window) window)
39     (type window parent) ; required
40 ram 1.1 (type int16 x y) ;required
41     (type card16 width height) ;required
42     (type card16 depth border-width)
43     (type (member :copy :input-output :input-only) class)
44     (type (or (member :copy) visual-info resource-id) visual)
45     (type (or null (member :none :parent-relative) pixel pixmap) background)
46     (type (or null (member :copy) pixel pixmap) border)
47     (type (or null bit-gravity) bit-gravity)
48     (type (or null win-gravity) gravity)
49     (type (or null (member :not-useful :when-mapped :always)) backing-store)
50     (type (or null pixel) backing-planes backing-pixel)
51     (type (or null event-mask) event-mask)
52     (type (or null device-event-mask) do-not-propagate-mask)
53     (type (or null (member :on :off)) save-under override-redirect)
54     (type (or null (member :copy) colormap) colormap)
55     (type (or null (member :none) cursor) cursor))
56 ram 1.3 (declare (clx-values window))
57 ram 1.1 (let* ((display (window-display parent))
58 ram 1.2 (window (or window (make-window :display display)))
59 ram 1.1 (wid (allocate-resource-id display window 'window))
60     back-pixmap back-pixel
61     border-pixmap border-pixel)
62     (declare (type display display)
63     (type window window)
64     (type resource-id wid)
65     (type (or null resource-id) back-pixmap border-pixmap)
66     (type (or null pixel) back-pixel border-pixel))
67     (setf (window-id window) wid)
68     (case background
69     ((nil) nil)
70     (:none (setq back-pixmap 0))
71     (:parent-relative (setq back-pixmap 1))
72     (otherwise
73     (if (type? background 'pixmap)
74     (setq back-pixmap (pixmap-id background))
75     (if (integerp background)
76     (setq back-pixel background)
77     (x-type-error background
78     '(or null (member :none :parent-relative) integer pixmap))))))
79     (case border
80     ((nil) nil)
81     (:copy (setq border-pixmap 0))
82     (otherwise
83     (if (type? border 'pixmap)
84     (setq border-pixmap (pixmap-id border))
85     (if (integerp border)
86     (setq border-pixel border)
87     (x-type-error border '(or null (member :copy) integer pixmap))))))
88     (when event-mask
89     (setq event-mask (encode-event-mask event-mask)))
90     (when do-not-propagate-mask
91     (setq do-not-propagate-mask (encode-device-event-mask do-not-propagate-mask)))
92    
93     ;Make the request
94 fgilham 1.8 (with-buffer-request (display +x-createwindow+)
95 ram 1.1 (data depth)
96     (resource-id wid)
97     (window parent)
98     (int16 x y)
99     (card16 width height border-width)
100     ((member16 :copy :input-output :input-only) class)
101     (resource-id (cond ((eq visual :copy)
102     0)
103     ((typep visual 'resource-id)
104     visual)
105     (t
106     (visual-info-id visual))))
107     (mask (card32 back-pixmap back-pixel border-pixmap border-pixel)
108 fgilham 1.8 ((member-vector +bit-gravity-vector+) bit-gravity)
109     ((member-vector +win-gravity-vector+) gravity)
110 ram 1.1 ((member :not-useful :when-mapped :always) backing-store)
111     (card32 backing-planes backing-pixel)
112     ((member :off :on) override-redirect save-under)
113     (card32 event-mask do-not-propagate-mask)
114     ((or (member :copy) colormap) colormap)
115     ((or (member :none) cursor) cursor)))
116     window))
117    
118     (defun destroy-window (window)
119     (declare (type window window))
120 fgilham 1.8 (with-buffer-request ((window-display window) +x-destroywindow+)
121 ram 1.1 (window window)))
122    
123     (defun destroy-subwindows (window)
124     (declare (type window window))
125 fgilham 1.8 (with-buffer-request ((window-display window) +x-destroysubwindows+)
126 ram 1.1 (window window)))
127    
128     (defun add-to-save-set (window)
129     (declare (type window window))
130 fgilham 1.8 (with-buffer-request ((window-display window) +x-changesaveset+)
131 ram 1.1 (data 0)
132     (window window)))
133    
134     (defun remove-from-save-set (window)
135     (declare (type window window))
136 fgilham 1.8 (with-buffer-request ((window-display window) +x-changesaveset+)
137 ram 1.1 (data 1)
138     (window window)))
139    
140     (defun reparent-window (window parent x y)
141     (declare (type window window parent)
142     (type int16 x y))
143 fgilham 1.8 (with-buffer-request ((window-display window) +x-reparentwindow+)
144 ram 1.1 (window window parent)
145     (int16 x y)))
146    
147     (defun map-window (window)
148     (declare (type window window))
149 fgilham 1.8 (with-buffer-request ((window-display window) +x-mapwindow+)
150 ram 1.1 (window window)))
151    
152     (defun map-subwindows (window)
153     (declare (type window window))
154 fgilham 1.8 (with-buffer-request ((window-display window) +x-mapsubwindows+)
155 ram 1.1 (window window)))
156    
157     (defun unmap-window (window)
158     (declare (type window window))
159 fgilham 1.8 (with-buffer-request ((window-display window) +x-unmapwindow+)
160 ram 1.1 (window window)))
161    
162     (defun unmap-subwindows (window)
163     (declare (type window window))
164 fgilham 1.8 (with-buffer-request ((window-display window) +x-unmapsubwindows+)
165 ram 1.1 (window window)))
166    
167     (defun circulate-window-up (window)
168     (declare (type window window))
169 fgilham 1.8 (with-buffer-request ((window-display window) +x-circulatewindow+)
170 ram 1.1 (data 0)
171     (window window)))
172    
173     (defun circulate-window-down (window)
174     (declare (type window window))
175 fgilham 1.8 (with-buffer-request ((window-display window) +x-circulatewindow+)
176 ram 1.1 (data 1)
177     (window window)))
178    
179     (defun query-tree (window &key (result-type 'list))
180     (declare (type window window)
181     (type t result-type)) ;;type specifier
182 ram 1.3 (declare (clx-values (clx-sequence window) parent root))
183 ram 1.1 (let ((display (window-display window)))
184     (multiple-value-bind (root parent sequence)
185 fgilham 1.8 (with-buffer-request-and-reply (display +x-querytree+ nil :sizes (8 16 32))
186 ram 1.1 ((window window))
187     (values
188     (window-get 8)
189     (resource-id-get 12)
190     (sequence-get :length (card16-get 16) :result-type result-type
191 fgilham 1.8 :index +replysize+)))
192 ram 1.1 ;; Parent is NIL for root window
193     (setq parent (and (plusp parent) (lookup-window display parent)))
194     (dotimes (i (length sequence)) ; Convert ID's to window's
195     (setf (elt sequence i) (lookup-window display (elt sequence i))))
196     (values sequence parent root))))
197    
198     ;; Although atom-ids are not visible in the normal user interface, atom-ids might
199     ;; appear in window properties and other user data, so conversion hooks are needed.
200    
201     (defun intern-atom (display name)
202     (declare (type display display)
203     (type xatom name))
204 ram 1.3 (declare (clx-values resource-id))
205 ram 1.2 (let ((name (if (or (null name) (keywordp name))
206     name
207     (kintern (string name)))))
208     (declare (type symbol name))
209     (or (atom-id name display)
210     (let ((string (symbol-name name)))
211 ram 1.1 (declare (type string string))
212     (multiple-value-bind (id)
213 fgilham 1.8 (with-buffer-request-and-reply (display +x-internatom+ 12 :sizes 32)
214 ram 1.1 ((data 0)
215     (card16 (length string))
216     (pad16 nil)
217     (string string))
218     (values
219     (resource-id-get 8)))
220     (declare (type resource-id id))
221 ram 1.2 (setf (atom-id name display) id)
222 ram 1.1 id)))))
223    
224     (defun find-atom (display name)
225     ;; Same as INTERN-ATOM, but with the ONLY-IF-EXISTS flag True
226     (declare (type display display)
227     (type xatom name))
228 ram 1.3 (declare (clx-values (or null resource-id)))
229 ram 1.2 (let ((name (if (or (null name) (keywordp name))
230     name
231     (kintern (string name)))))
232     (declare (type symbol name))
233     (or (atom-id name display)
234     (let ((string (symbol-name name)))
235 ram 1.1 (declare (type string string))
236     (multiple-value-bind (id)
237 fgilham 1.8 (with-buffer-request-and-reply (display +x-internatom+ 12 :sizes 32)
238 ram 1.1 ((data 1)
239     (card16 (length string))
240     (pad16 nil)
241     (string string))
242     (values
243     (or-get 8 null resource-id)))
244     (declare (type (or null resource-id) id))
245     (when id
246 ram 1.2 (setf (atom-id name display) id))
247 ram 1.1 id)))))
248    
249     (defun atom-name (display atom-id)
250     (declare (type display display)
251     (type resource-id atom-id))
252 ram 1.3 (declare (clx-values keyword))
253 ram 1.2 (if (zerop atom-id)
254     nil
255 ram 1.1 (or (id-atom atom-id display)
256     (let ((keyword
257     (kintern
258 ram 1.2 (with-buffer-request-and-reply
259 fgilham 1.8 (display +x-getatomname+ nil :sizes (16))
260 ram 1.1 ((resource-id atom-id))
261     (values
262 fgilham 1.8 (string-get (card16-get 8) +replysize+))))))
263 ram 1.1 (declare (type keyword keyword))
264     (setf (atom-id keyword display) atom-id)
265 ram 1.2 keyword))))
266 ram 1.1
267     ;;; For binary compatibility with older code
268     (defun lookup-xatom (display atom-id)
269     (declare (type display display)
270     (type resource-id atom-id))
271     (atom-name display atom-id))
272    
273     (defun change-property (window property data type format
274     &key (mode :replace) (start 0) end transform)
275     ; Start and end affect sub-sequence extracted from data.
276     ; Transform is applied to each extracted element.
277     (declare (type window window)
278     (type xatom property type)
279     (type (member 8 16 32) format)
280     (type sequence data)
281     (type (member :replace :prepend :append) mode)
282     (type array-index start)
283     (type (or null array-index) end)
284 ram 1.3 (type (or null (function (t) integer)) transform))
285 ram 1.1 (unless end (setq end (length data)))
286     (let* ((display (window-display window))
287     (length (index- end start))
288     (property-id (intern-atom display property))
289     (type-id (intern-atom display type)))
290     (declare (type display display)
291     (type array-index length)
292     (type resource-id property-id type-id))
293 fgilham 1.8 (with-buffer-request (display +x-changeproperty+)
294 ram 1.1 ((data (member :replace :prepend :append)) mode)
295     (window window)
296     (resource-id property-id type-id)
297     (card8 format)
298     (card32 length)
299     (progn
300     (ecase format
301     (8 (sequence-put 24 data :format card8
302     :start start :end end :transform transform))
303     (16 (sequence-put 24 data :format card16
304     :start start :end end :transform transform))
305     (32 (sequence-put 24 data :format card32
306     :start start :end end :transform transform)))))))
307    
308     (defun delete-property (window property)
309     (declare (type window window)
310     (type xatom property))
311     (let* ((display (window-display window))
312     (property-id (intern-atom display property)))
313     (declare (type display display)
314     (type resource-id property-id))
315 fgilham 1.8 (with-buffer-request (display +x-deleteproperty+)
316 ram 1.1 (window window)
317     (resource-id property-id))))
318    
319     (defun get-property (window property
320     &key type (start 0) end delete-p (result-type 'list) transform)
321     ;; Transform is applied to each integer retrieved.
322     (declare (type window window)
323     (type xatom property)
324     (type (or null xatom) type)
325     (type array-index start)
326     (type (or null array-index) end)
327 dtc 1.4 (type generalized-boolean delete-p)
328 ram 1.1 (type t result-type) ;a sequence type
329 ram 1.3 (type (or null (function (integer) t)) transform))
330     (declare (clx-values data (or null type) format bytes-after))
331 ram 1.1 (let* ((display (window-display window))
332     (property-id (intern-atom display property))
333     (type-id (and type (intern-atom display type))))
334     (declare (type display display)
335     (type resource-id property-id)
336     (type (or null resource-id) type-id))
337     (multiple-value-bind (reply-format reply-type bytes-after data)
338 fgilham 1.8 (with-buffer-request-and-reply (display +x-getproperty+ nil :sizes (8 32))
339 ram 1.1 (((data boolean) delete-p)
340     (window window)
341     (resource-id property-id)
342     ((or null resource-id) type-id)
343     (card32 start)
344     (card32 (index- (or end 64000) start)))
345     (let ((reply-format (card8-get 1))
346     (reply-type (card32-get 8))
347     (bytes-after (card32-get 12))
348     (nitems (card32-get 16)))
349     (values
350     reply-format
351     reply-type
352     bytes-after
353     (and (plusp nitems)
354     (ecase reply-format
355     (0 nil) ;; (make-sequence result-type 0) ;; Property not found.
356     (8 (sequence-get :result-type result-type :format card8
357     :length nitems :transform transform
358 fgilham 1.8 :index +replysize+))
359 ram 1.1 (16 (sequence-get :result-type result-type :format card16
360     :length nitems :transform transform
361 fgilham 1.8 :index +replysize+))
362 ram 1.1 (32 (sequence-get :result-type result-type :format card32
363     :length nitems :transform transform
364 fgilham 1.8 :index +replysize+)))))))
365 ram 1.1 (values data
366     (and (plusp reply-type) (atom-name display reply-type))
367     reply-format
368     bytes-after))))
369    
370     (defun rotate-properties (window properties &optional (delta 1))
371     ;; Positive rotates left, negative rotates right (opposite of actual protocol request).
372     (declare (type window window)
373     (type sequence properties) ;; sequence of xatom
374     (type int16 delta))
375     (let* ((display (window-display window))
376     (length (length properties))
377     (sequence (make-array length)))
378     (declare (type display display)
379     (type array-index length))
380     (with-vector (sequence vector)
381     ;; Atoms must be interned before the RotateProperties request
382     ;; is started to allow InternAtom requests to be made.
383     (dotimes (i length)
384     (setf (aref sequence i) (intern-atom display (elt properties i))))
385 fgilham 1.8 (with-buffer-request (display +x-rotateproperties+)
386 ram 1.1 (window window)
387     (card16 length)
388     (int16 (- delta))
389     ((sequence :end length) sequence))))
390     nil)
391    
392     (defun list-properties (window &key (result-type 'list))
393     (declare (type window window)
394     (type t result-type)) ;; a sequence type
395 ram 1.3 (declare (clx-values (clx-sequence keyword)))
396 ram 1.1 (let ((display (window-display window)))
397     (multiple-value-bind (seq)
398 fgilham 1.8 (with-buffer-request-and-reply (display +x-listproperties+ nil :sizes 16)
399 ram 1.1 ((window window))
400     (values
401     (sequence-get :result-type result-type :length (card16-get 8)
402 fgilham 1.8 :index +replysize+)))
403 ram 1.1 ;; lookup the atoms in the sequence
404     (if (listp seq)
405     (do ((elt seq (cdr elt)))
406     ((endp elt) seq)
407     (setf (car elt) (atom-name display (car elt))))
408     (dotimes (i (length seq) seq)
409     (setf (aref seq i) (atom-name display (aref seq i))))))))
410    
411     (defun selection-owner (display selection)
412     (declare (type display display)
413     (type xatom selection))
414 ram 1.3 (declare (clx-values (or null window)))
415 ram 1.1 (let ((selection-id (intern-atom display selection)))
416     (declare (type resource-id selection-id))
417     (multiple-value-bind (window)
418 fgilham 1.8 (with-buffer-request-and-reply (display +x-getselectionowner+ 12 :sizes 32)
419 ram 1.1 ((resource-id selection-id))
420     (values
421     (resource-id-or-nil-get 8)))
422     (and window (lookup-window display window)))))
423    
424     (defun set-selection-owner (display selection owner &optional time)
425     (declare (type display display)
426     (type xatom selection)
427     (type (or null window) owner)
428     (type timestamp time))
429     (let ((selection-id (intern-atom display selection)))
430     (declare (type resource-id selection-id))
431 fgilham 1.8 (with-buffer-request (display +x-setselectionowner+)
432 ram 1.1 ((or null window) owner)
433     (resource-id selection-id)
434     ((or null card32) time))
435     owner))
436    
437     (defsetf selection-owner (display selection &optional time) (owner)
438     ;; A bit strange, but retains setf form.
439     `(set-selection-owner ,display ,selection ,owner ,time))
440    
441     (defun convert-selection (selection type requestor &optional property time)
442     (declare (type xatom selection type)
443     (type window requestor)
444     (type (or null xatom) property)
445     (type timestamp time))
446     (let* ((display (window-display requestor))
447     (selection-id (intern-atom display selection))
448     (type-id (intern-atom display type))
449     (property-id (and property (intern-atom display property))))
450     (declare (type display display)
451     (type resource-id selection-id type-id)
452     (type (or null resource-id) property-id))
453 fgilham 1.8 (with-buffer-request (display +x-convertselection+)
454 ram 1.1 (window requestor)
455     (resource-id selection-id type-id)
456     ((or null resource-id) property-id)
457     ((or null card32) time))))
458    
459     (defun send-event (window event-key event-mask &rest args
460     &key propagate-p display &allow-other-keys)
461     ;; Additional arguments depend on event-key, and are as specified further below
462     ;; with declare-event, except that both resource-ids and resource objects are
463     ;; accepted in the event components. The display argument is only required if the
464     ;; window is :pointer-window or :input-focus.
465     (declare (type (or window (member :pointer-window :input-focus)) window)
466     (type event-key event-key)
467     (type (or null event-mask) event-mask)
468 dtc 1.4 (type generalized-boolean propagate-p)
469 ram 1.1 (type (or null display) display)
470     (dynamic-extent args))
471     (unless event-mask (setq event-mask 0))
472     (unless display (setq display (window-display window)))
473     (let ((internal-event-code (get-event-code event-key))
474     (external-event-code (get-external-event-code display event-key)))
475     (declare (type card8 internal-event-code external-event-code))
476     ;; Ensure keyword atom-id's are cached
477     (dolist (arg (cdr (assoc event-key '((:property-notify :atom)
478     (:selection-clear :selection)
479     (:selection-request :selection :target :property)
480     (:selection-notify :selection :target :property)
481     (:client-message :type))
482     :test #'eq)))
483     (let ((keyword (getf args arg)))
484     (intern-atom display keyword)))
485     ;; Make the sendevent request
486 fgilham 1.8 (with-buffer-request (display +x-sendevent+)
487 ram 1.1 ((data boolean) propagate-p)
488     (length 11) ;; 3 word request + 8 words for event = 11
489     ((or (member :pointer-window :input-focus) window) window)
490     (card32 (encode-event-mask event-mask))
491     (card8 external-event-code)
492     (progn
493     (apply (svref *event-send-vector* internal-event-code) display args)
494     (setf (buffer-boffset display) (index+ buffer-boffset 44))))))
495    
496     (defun grab-pointer (window event-mask
497     &key owner-p sync-pointer-p sync-keyboard-p confine-to cursor time)
498     (declare (type window window)
499     (type pointer-event-mask event-mask)
500 dtc 1.4 (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p)
501 ram 1.1 (type (or null window) confine-to)
502     (type (or null cursor) cursor)
503     (type timestamp time))
504 ram 1.3 (declare (clx-values grab-status))
505 ram 1.1 (let ((display (window-display window)))
506 fgilham 1.8 (with-buffer-request-and-reply (display +x-grabpointer+ nil :sizes 8)
507 ram 1.1 (((data boolean) owner-p)
508     (window window)
509     (card16 (encode-pointer-event-mask event-mask))
510     (boolean (not sync-pointer-p) (not sync-keyboard-p))
511     ((or null window) confine-to)
512     ((or null cursor) cursor)
513     ((or null card32) time))
514     (values
515     (member8-get 1 :success :already-grabbed :invalid-time :not-viewable :frozen)))))
516    
517     (defun ungrab-pointer (display &key time)
518     (declare (type timestamp time))
519 fgilham 1.8 (with-buffer-request (display +x-ungrabpointer+)
520 ram 1.1 ((or null card32) time)))
521    
522     (defun grab-button (window button event-mask
523 toy 1.6 &key (modifiers :any)
524 ram 1.1 owner-p sync-pointer-p sync-keyboard-p confine-to cursor)
525     (declare (type window window)
526     (type (or (member :any) card8) button)
527     (type modifier-mask modifiers)
528     (type pointer-event-mask event-mask)
529 dtc 1.4 (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p)
530 ram 1.1 (type (or null window) confine-to)
531     (type (or null cursor) cursor))
532 fgilham 1.8 (with-buffer-request ((window-display window) +x-grabbutton+)
533 ram 1.1 ((data boolean) owner-p)
534     (window window)
535     (card16 (encode-pointer-event-mask event-mask))
536     (boolean (not sync-pointer-p) (not sync-keyboard-p))
537     ((or null window) confine-to)
538     ((or null cursor) cursor)
539     (card8 (if (eq button :any) 0 button))
540     (pad8 1)
541     (card16 (encode-modifier-mask modifiers))))
542    
543 toy 1.6 (defun ungrab-button (window button &key (modifiers :any))
544 ram 1.1 (declare (type window window)
545     (type (or (member :any) card8) button)
546     (type modifier-mask modifiers))
547 fgilham 1.8 (with-buffer-request ((window-display window) +x-ungrabbutton+)
548 ram 1.1 (data (if (eq button :any) 0 button))
549     (window window)
550     (card16 (encode-modifier-mask modifiers))))
551    
552     (defun change-active-pointer-grab (display event-mask &optional cursor time)
553     (declare (type display display)
554     (type pointer-event-mask event-mask)
555     (type (or null cursor) cursor)
556     (type timestamp time))
557 fgilham 1.8 (with-buffer-request (display +x-changeactivepointergrab+)
558 ram 1.1 ((or null cursor) cursor)
559     ((or null card32) time)
560     (card16 (encode-pointer-event-mask event-mask))))
561    
562     (defun grab-keyboard (window &key owner-p sync-pointer-p sync-keyboard-p time)
563     (declare (type window window)
564 dtc 1.4 (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p)
565 ram 1.1 (type timestamp time))
566 ram 1.3 (declare (clx-values grab-status))
567 ram 1.1 (let ((display (window-display window)))
568 fgilham 1.8 (with-buffer-request-and-reply (display +x-grabkeyboard+ nil :sizes 8)
569 ram 1.1 (((data boolean) owner-p)
570     (window window)
571     ((or null card32) time)
572     (boolean (not sync-pointer-p) (not sync-keyboard-p)))
573     (values
574     (member8-get 1 :success :already-grabbed :invalid-time :not-viewable :frozen)))))
575    
576     (defun ungrab-keyboard (display &key time)
577     (declare (type display display)
578     (type timestamp time))
579 fgilham 1.8 (with-buffer-request (display +x-ungrabkeyboard+)
580 ram 1.1 ((or null card32) time)))
581    
582     (defun grab-key (window key &key (modifiers 0) owner-p sync-pointer-p sync-keyboard-p)
583     (declare (type window window)
584 dtc 1.4 (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p)
585 ram 1.1 (type (or (member :any) card8) key)
586     (type modifier-mask modifiers))
587 fgilham 1.8 (with-buffer-request ((window-display window) +x-grabkey+)
588 ram 1.1 ((data boolean) owner-p)
589     (window window)
590     (card16 (encode-modifier-mask modifiers))
591     (card8 (if (eq key :any) 0 key))
592     (boolean (not sync-pointer-p) (not sync-keyboard-p))))
593    
594     (defun ungrab-key (window key &key (modifiers 0))
595     (declare (type window window)
596     (type (or (member :any) card8) key)
597     (type modifier-mask modifiers))
598 fgilham 1.8 (with-buffer-request ((window-display window) +x-ungrabkey+)
599 ram 1.1 (data (if (eq key :any) 0 key))
600     (window window)
601     (card16 (encode-modifier-mask modifiers))))
602    
603     (defun allow-events (display mode &optional time)
604     (declare (type display display)
605     (type (member :async-pointer :sync-pointer :replay-pointer
606     :async-keyboard :sync-keyboard :replay-keyboard
607     :async-both :sync-both)
608     mode)
609     (type timestamp time))
610 fgilham 1.8 (with-buffer-request (display +x-allowevents+)
611 ram 1.1 ((data (member :async-pointer :sync-pointer :replay-pointer
612     :async-keyboard :sync-keyboard :replay-keyboard
613     :async-both :sync-both))
614     mode)
615     ((or null card32) time)))
616    
617     (defun grab-server (display)
618     (declare (type display display))
619 fgilham 1.8 (with-buffer-request (display +x-grabserver+)))
620 ram 1.1
621     (defun ungrab-server (display)
622 fgilham 1.8 (with-buffer-request (display +x-ungrabserver+)))
623 ram 1.1
624     (defmacro with-server-grabbed ((display) &body body)
625     ;; The body is not surrounded by a with-display.
626     (let ((disp (if (symbolp display) display (gensym))))
627     `(let ((,disp ,display))
628     (declare (type display ,disp))
629     (unwind-protect
630     (progn
631     (grab-server ,disp)
632     ,@body)
633     (ungrab-server ,disp)))))
634    
635     (defun query-pointer (window)
636     (declare (type window window))
637 ram 1.3 (declare (clx-values x y same-screen-p child mask root-x root-y root))
638 ram 1.1 (let ((display (window-display window)))
639 fgilham 1.8 (with-buffer-request-and-reply (display +x-querypointer+ 26 :sizes (8 16 32))
640 ram 1.1 ((window window))
641     (values
642     (int16-get 20)
643     (int16-get 22)
644     (boolean-get 1)
645     (or-get 12 null window)
646     (card16-get 24)
647     (int16-get 16)
648     (int16-get 18)
649     (window-get 8)))))
650    
651     (defun pointer-position (window)
652     (declare (type window window))
653 ram 1.3 (declare (clx-values x y same-screen-p))
654 ram 1.1 (let ((display (window-display window)))
655 fgilham 1.8 (with-buffer-request-and-reply (display +x-querypointer+ 24 :sizes (8 16))
656 ram 1.1 ((window window))
657     (values
658     (int16-get 20)
659     (int16-get 22)
660     (boolean-get 1)))))
661    
662     (defun global-pointer-position (display)
663     (declare (type display display))
664 ram 1.3 (declare (clx-values root-x root-y root))
665 fgilham 1.8 (with-buffer-request-and-reply (display +x-querypointer+ 20 :sizes (16 32))
666 ram 1.1 ((window (screen-root (first (display-roots display)))))
667     (values
668     (int16-get 16)
669     (int16-get 18)
670     (window-get 8))))
671    
672     (defun motion-events (window &key start stop (result-type 'list))
673     (declare (type window window)
674     (type timestamp start stop)
675     (type t result-type)) ;; a type specifier
676 ram 1.3 (declare (clx-values (repeat-seq (integer x) (integer y) (timestamp time))))
677 ram 1.1 (let ((display (window-display window)))
678 fgilham 1.8 (with-buffer-request-and-reply (display +x-getmotionevents+ nil :sizes 32)
679 ram 1.1 ((window window)
680     ((or null card32) start stop))
681     (values
682     (sequence-get :result-type result-type :length (index* (card32-get 8) 3)
683 fgilham 1.8 :index +replysize+)))))
684 ram 1.1
685     (defun translate-coordinates (src src-x src-y dst)
686     ;; Returns NIL when not on the same screen
687     (declare (type window src)
688     (type int16 src-x src-y)
689     (type window dst))
690 ram 1.3 (declare (clx-values dst-x dst-y child))
691 ram 1.1 (let ((display (window-display src)))
692 fgilham 1.8 (with-buffer-request-and-reply (display +x-translatecoords+ 16 :sizes (8 16 32))
693 ram 1.1 ((window src dst)
694     (int16 src-x src-y))
695     (and (boolean-get 1)
696     (values
697     (int16-get 12)
698     (int16-get 14)
699     (or-get 8 null window))))))
700    
701     (defun warp-pointer (dst dst-x dst-y)
702     (declare (type window dst)
703     (type int16 dst-x dst-y))
704 fgilham 1.8 (with-buffer-request ((window-display dst) +x-warppointer+)
705 ram 1.1 (resource-id 0) ;; None
706     (window dst)
707     (int16 0 0)
708     (card16 0 0)
709     (int16 dst-x dst-y)))
710    
711     (defun warp-pointer-relative (display x-off y-off)
712     (declare (type display display)
713     (type int16 x-off y-off))
714 fgilham 1.8 (with-buffer-request (display +x-warppointer+)
715 ram 1.1 (resource-id 0) ;; None
716     (resource-id 0) ;; None
717     (int16 0 0)
718     (card16 0 0)
719     (int16 x-off y-off)))
720    
721     (defun warp-pointer-if-inside (dst dst-x dst-y src src-x src-y
722     &optional src-width src-height)
723     ;; Passing in a zero src-width or src-height is a no-op.
724     ;; A null src-width or src-height translates into a zero value in the protocol request.
725     (declare (type window dst src)
726     (type int16 dst-x dst-y src-x src-y)
727     (type (or null card16) src-width src-height))
728     (unless (or (eql src-width 0) (eql src-height 0))
729 fgilham 1.8 (with-buffer-request ((window-display dst) +x-warppointer+)
730 ram 1.1 (window src dst)
731     (int16 src-x src-y)
732     (card16 (or src-width 0) (or src-height 0))
733     (int16 dst-x dst-y))))
734    
735     (defun warp-pointer-relative-if-inside (x-off y-off src src-x src-y
736     &optional src-width src-height)
737     ;; Passing in a zero src-width or src-height is a no-op.
738     ;; A null src-width or src-height translates into a zero value in the protocol request.
739     (declare (type window src)
740     (type int16 x-off y-off src-x src-y)
741     (type (or null card16) src-width src-height))
742     (unless (or (eql src-width 0) (eql src-height 0))
743 fgilham 1.8 (with-buffer-request ((window-display src) +x-warppointer+)
744 ram 1.1 (window src)
745     (resource-id 0) ;; None
746     (int16 src-x src-y)
747     (card16 (or src-width 0) (or src-height 0))
748     (int16 x-off y-off))))
749    
750     (defun set-input-focus (display focus revert-to &optional time)
751     (declare (type display display)
752     (type (or (member :none :pointer-root) window) focus)
753 ram 1.2 (type (member :none :pointer-root :parent) revert-to)
754 ram 1.1 (type timestamp time))
755 fgilham 1.8 (with-buffer-request (display +x-setinputfocus+)
756 ram 1.2 ((data (member :none :pointer-root :parent)) revert-to)
757 ram 1.1 ((or window (member :none :pointer-root)) focus)
758     ((or null card32) time)))
759    
760     (defun input-focus (display)
761     (declare (type display display))
762 ram 1.3 (declare (clx-values focus revert-to))
763 fgilham 1.8 (with-buffer-request-and-reply (display +x-getinputfocus+ 16 :sizes (8 32))
764 ram 1.1 ()
765     (values
766 emarsden 1.7 (or-get 8 window (member :none :pointer-root))
767 ram 1.1 (member8-get 1 :none :pointer-root :parent))))
768    
769     (defun query-keymap (display &optional bit-vector)
770     (declare (type display display)
771     (type (or null (bit-vector 256)) bit-vector))
772 ram 1.3 (declare (clx-values (bit-vector 256)))
773 fgilham 1.8 (with-buffer-request-and-reply (display +x-querykeymap+ 40 :sizes 8)
774 ram 1.1 ()
775     (values
776     (bit-vector256-get 8 8 bit-vector))))
777    
778     (defun create-pixmap (&key
779 ram 1.2 pixmap
780 ram 1.1 (width (required-arg width))
781     (height (required-arg height))
782     (depth (required-arg depth))
783     (drawable (required-arg drawable)))
784 ram 1.2 (declare (type (or null pixmap) pixmap)
785     (type card8 depth) ;; required
786 ram 1.1 (type card16 width height) ;; required
787     (type drawable drawable)) ;; required
788 ram 1.3 (declare (clx-values pixmap))
789 ram 1.1 (let* ((display (drawable-display drawable))
790 ram 1.2 (pixmap (or pixmap (make-pixmap :display display)))
791 ram 1.1 (pid (allocate-resource-id display pixmap 'pixmap)))
792     (setf (pixmap-id pixmap) pid)
793 fgilham 1.8 (with-buffer-request (display +x-createpixmap+)
794 ram 1.1 (data depth)
795     (resource-id pid)
796     (drawable drawable)
797     (card16 width height))
798     pixmap))
799    
800     (defun free-pixmap (pixmap)
801     (declare (type pixmap pixmap))
802     (let ((display (pixmap-display pixmap)))
803 fgilham 1.8 (with-buffer-request (display +x-freepixmap+)
804 ram 1.1 (pixmap pixmap))
805     (deallocate-resource-id display (pixmap-id pixmap) 'pixmap)))
806    
807     (defun clear-area (window &key (x 0) (y 0) width height exposures-p)
808     ;; Passing in a zero width or height is a no-op.
809     ;; A null width or height translates into a zero value in the protocol request.
810     (declare (type window window)
811     (type int16 x y)
812     (type (or null card16) width height)
813 dtc 1.4 (type generalized-boolean exposures-p))
814 ram 1.1 (unless (or (eql width 0) (eql height 0))
815 fgilham 1.8 (with-buffer-request ((window-display window) +x-cleartobackground+)
816 ram 1.1 ((data boolean) exposures-p)
817     (window window)
818     (int16 x y)
819     (card16 (or width 0) (or height 0)))))
820    
821     (defun copy-area (src gcontext src-x src-y width height dst dst-x dst-y)
822     (declare (type drawable src dst)
823     (type gcontext gcontext)
824     (type int16 src-x src-y dst-x dst-y)
825     (type card16 width height))
826 fgilham 1.8 (with-buffer-request ((drawable-display src) +x-copyarea+ :gc-force gcontext)
827 ram 1.1 (drawable src dst)
828     (gcontext gcontext)
829     (int16 src-x src-y dst-x dst-y)
830     (card16 width height)))
831    
832     (defun copy-plane (src gcontext plane src-x src-y width height dst dst-x dst-y)
833     (declare (type drawable src dst)
834     (type gcontext gcontext)
835     (type pixel plane)
836     (type int16 src-x src-y dst-x dst-y)
837     (type card16 width height))
838 fgilham 1.8 (with-buffer-request ((drawable-display src) +x-copyplane+ :gc-force gcontext)
839 ram 1.1 (drawable src dst)
840     (gcontext gcontext)
841     (int16 src-x src-y dst-x dst-y)
842     (card16 width height)
843     (card32 plane)))
844    
845     (defun create-colormap (visual-info window &optional alloc-p)
846     (declare (type (or visual-info resource-id) visual-info)
847     (type window window)
848 dtc 1.4 (type generalized-boolean alloc-p))
849 ram 1.3 (declare (clx-values colormap))
850 ram 1.1 (let ((display (window-display window)))
851     (when (typep visual-info 'resource-id)
852     (setf visual-info (visual-info display visual-info)))
853     (let* ((colormap (make-colormap :display display :visual-info visual-info))
854     (id (allocate-resource-id display colormap 'colormap)))
855     (setf (colormap-id colormap) id)
856 fgilham 1.8 (with-buffer-request (display +x-createcolormap+)
857 ram 1.1 ((data boolean) alloc-p)
858     (card29 id)
859     (window window)
860     (card29 (visual-info-id visual-info)))
861     colormap)))
862    
863     (defun free-colormap (colormap)
864     (declare (type colormap colormap))
865     (let ((display (colormap-display colormap)))
866 fgilham 1.8 (with-buffer-request (display +x-freecolormap+)
867 ram 1.1 (colormap colormap))
868     (deallocate-resource-id display (colormap-id colormap) 'colormap)))
869    
870     (defun copy-colormap-and-free (colormap)
871     (declare (type colormap colormap))
872 ram 1.3 (declare (clx-values colormap))
873 ram 1.1 (let* ((display (colormap-display colormap))
874     (new-colormap (make-colormap :display display
875     :visual-info (colormap-visual-info colormap)))
876     (id (allocate-resource-id display new-colormap 'colormap)))
877     (setf (colormap-id new-colormap) id)
878 fgilham 1.8 (with-buffer-request (display +x-copycolormapandfree+)
879 ram 1.1 (resource-id id)
880     (colormap colormap))
881     new-colormap))
882    
883     (defun install-colormap (colormap)
884     (declare (type colormap colormap))
885 fgilham 1.8 (with-buffer-request ((colormap-display colormap) +x-installcolormap+)
886 ram 1.1 (colormap colormap)))
887    
888     (defun uninstall-colormap (colormap)
889     (declare (type colormap colormap))
890 fgilham 1.8 (with-buffer-request ((colormap-display colormap) +x-uninstallcolormap+)
891 ram 1.1 (colormap colormap)))
892    
893     (defun installed-colormaps (window &key (result-type 'list))
894     (declare (type window window)
895     (type t result-type)) ;; CL type
896 ram 1.3 (declare (clx-values (clx-sequence colormap)))
897 ram 1.1 (let ((display (window-display window)))
898     (flet ((get-colormap (id)
899     (lookup-colormap display id)))
900 fgilham 1.8 (with-buffer-request-and-reply (display +x-listinstalledcolormaps+ nil :sizes 16)
901 ram 1.1 ((window window))
902     (values
903     (sequence-get :result-type result-type :length (card16-get 8)
904 fgilham 1.8 :transform #'get-colormap :index +replysize+))))))
905 ram 1.1
906     (defun alloc-color (colormap color)
907     (declare (type colormap colormap)
908     (type (or stringable color) color))
909 ram 1.3 (declare (clx-values pixel screen-color exact-color))
910 ram 1.1 (let ((display (colormap-display colormap)))
911     (etypecase color
912     (color
913 fgilham 1.8 (with-buffer-request-and-reply (display +x-alloccolor+ 20 :sizes (16 32))
914 ram 1.1 ((colormap colormap)
915     (rgb-val (color-red color)
916     (color-green color)
917     (color-blue color))
918     (pad16 nil))
919     (values
920     (card32-get 16)
921     (make-color :red (rgb-val-get 8)
922     :green (rgb-val-get 10)
923     :blue (rgb-val-get 12))
924     color)))
925     (stringable
926     (let* ((string (string color))
927     (length (length string)))
928 fgilham 1.8 (with-buffer-request-and-reply (display +x-allocnamedcolor+ 24 :sizes (16 32))
929 ram 1.1 ((colormap colormap)
930     (card16 length)
931     (pad16 nil)
932     (string string))
933     (values
934     (card32-get 8)
935 ram 1.2 (make-color :red (rgb-val-get 18)
936     :green (rgb-val-get 20)
937     :blue (rgb-val-get 22))
938 ram 1.1 (make-color :red (rgb-val-get 12)
939     :green (rgb-val-get 14)
940 ram 1.2 :blue (rgb-val-get 16)))))))))
941 ram 1.1
942     (defun alloc-color-cells (colormap colors &key (planes 0) contiguous-p (result-type 'list))
943     (declare (type colormap colormap)
944     (type card16 colors planes)
945 dtc 1.4 (type generalized-boolean contiguous-p)
946 ram 1.1 (type t result-type)) ;; CL type
947 ram 1.3 (declare (clx-values (clx-sequence pixel) (clx-sequence mask)))
948 ram 1.1 (let ((display (colormap-display colormap)))
949 fgilham 1.8 (with-buffer-request-and-reply (display +x-alloccolorcells+ nil :sizes 16)
950 ram 1.1 (((data boolean) contiguous-p)
951     (colormap colormap)
952     (card16 colors planes))
953     (let ((pixel-length (card16-get 8))
954     (mask-length (card16-get 10)))
955     (values
956 fgilham 1.8 (sequence-get :result-type result-type :length pixel-length :index +replysize+)
957 ram 1.1 (sequence-get :result-type result-type :length mask-length
958 fgilham 1.8 :index (index+ +replysize+ (index* pixel-length 4))))))))
959 ram 1.1
960     (defun alloc-color-planes (colormap colors
961     &key (reds 0) (greens 0) (blues 0)
962     contiguous-p (result-type 'list))
963     (declare (type colormap colormap)
964     (type card16 colors reds greens blues)
965 dtc 1.4 (type generalized-boolean contiguous-p)
966 ram 1.1 (type t result-type)) ;; CL type
967 ram 1.3 (declare (clx-values (clx-sequence pixel) red-mask green-mask blue-mask))
968 ram 1.1 (let ((display (colormap-display colormap)))
969 fgilham 1.8 (with-buffer-request-and-reply (display +x-alloccolorplanes+ nil :sizes (16 32))
970 ram 1.1 (((data boolean) contiguous-p)
971     (colormap colormap)
972     (card16 colors reds greens blues))
973     (let ((red-mask (card32-get 12))
974     (green-mask (card32-get 16))
975     (blue-mask (card32-get 20)))
976     (values
977 fgilham 1.8 (sequence-get :result-type result-type :length (card16-get 8) :index +replysize+)
978 ram 1.1 red-mask green-mask blue-mask)))))
979    
980     (defun free-colors (colormap pixels &optional (plane-mask 0))
981     (declare (type colormap colormap)
982     (type sequence pixels) ;; Sequence of integers
983     (type pixel plane-mask))
984 fgilham 1.8 (with-buffer-request ((colormap-display colormap) +x-freecolors+)
985 ram 1.1 (colormap colormap)
986     (card32 plane-mask)
987     (sequence pixels)))
988    
989     (defun store-color (colormap pixel spec &key (red-p t) (green-p t) (blue-p t))
990     (declare (type colormap colormap)
991     (type pixel pixel)
992     (type (or stringable color) spec)
993 dtc 1.4 (type generalized-boolean red-p green-p blue-p))
994 ram 1.1 (let ((display (colormap-display colormap))
995     (flags 0))
996     (declare (type display display)
997     (type card8 flags))
998     (when red-p (setq flags 1))
999     (when green-p (incf flags 2))
1000     (when blue-p (incf flags 4))
1001     (etypecase spec
1002     (color
1003 fgilham 1.8 (with-buffer-request (display +x-storecolors+)
1004 ram 1.1 (colormap colormap)
1005     (card32 pixel)
1006     (rgb-val (color-red spec)
1007     (color-green spec)
1008     (color-blue spec))
1009     (card8 flags)
1010     (pad8 nil)))
1011     (stringable
1012     (let* ((string (string spec))
1013     (length (length string)))
1014 fgilham 1.8 (with-buffer-request (display +x-storenamedcolor+)
1015 ram 1.1 ((data card8) flags)
1016     (colormap colormap)
1017     (card32 pixel)
1018     (card16 length)
1019     (pad16 nil)
1020     (string string)))))))
1021    
1022     (defun store-colors (colormap specs &key (red-p t) (green-p t) (blue-p t))
1023     ;; If stringables are specified for colors, it is unspecified whether all
1024     ;; stringables are first resolved and then a single StoreColors protocol request is
1025     ;; issued, or whether multiple StoreColors protocol requests are issued.
1026     (declare (type colormap colormap)
1027     (type sequence specs)
1028 dtc 1.4 (type generalized-boolean red-p green-p blue-p))
1029 ram 1.1 (etypecase specs
1030     (list
1031 ram 1.2 (do ((spec specs (cddr spec)))
1032 ram 1.1 ((endp spec))
1033 ram 1.2 (store-color colormap (car spec) (cadr spec) :red-p red-p :green-p green-p :blue-p blue-p)))
1034 ram 1.1 (vector
1035 ram 1.2 (do ((i 0 (+ i 2))
1036     (len (length specs)))
1037 ram 1.1 ((>= i len))
1038 ram 1.2 (store-color colormap (aref specs i) (aref specs (1+ i)) :red-p red-p :green-p green-p :blue-p blue-p)))))
1039 ram 1.1
1040     (defun query-colors (colormap pixels &key (result-type 'list))
1041     (declare (type colormap colormap)
1042     (type sequence pixels) ;; sequence of integer
1043     (type t result-type)) ;; a type specifier
1044 ram 1.3 (declare (clx-values (clx-sequence color)))
1045 ram 1.1 (let ((display (colormap-display colormap)))
1046 fgilham 1.8 (with-buffer-request-and-reply (display +x-querycolors+ nil :sizes (8 16))
1047 ram 1.1 ((colormap colormap)
1048     (sequence pixels))
1049     (let ((sequence (make-sequence result-type (card16-get 8))))
1050 fgilham 1.8 (advance-buffer-offset +replysize+)
1051 ram 1.1 (dotimes (i (length sequence) sequence)
1052     (setf (elt sequence i)
1053     (make-color :red (rgb-val-get 0)
1054     :green (rgb-val-get 2)
1055     :blue (rgb-val-get 4)))
1056     (advance-buffer-offset 8))))))
1057    
1058     (defun lookup-color (colormap name)
1059     (declare (type colormap colormap)
1060     (type stringable name))
1061 ram 1.3 (declare (clx-values screen-color true-color))
1062 ram 1.1 (let* ((display (colormap-display colormap))
1063     (string (string name))
1064     (length (length string)))
1065 fgilham 1.8 (with-buffer-request-and-reply (display +x-lookupcolor+ 20 :sizes 16)
1066 ram 1.1 ((colormap colormap)
1067     (card16 length)
1068     (pad16 nil)
1069     (string string))
1070     (values
1071     (make-color :red (rgb-val-get 14)
1072     :green (rgb-val-get 16)
1073     :blue (rgb-val-get 18))
1074     (make-color :red (rgb-val-get 8)
1075     :green (rgb-val-get 10)
1076     :blue (rgb-val-get 12))))))
1077    
1078     (defun create-cursor (&key
1079     (source (required-arg source))
1080     mask
1081     (x (required-arg x))
1082     (y (required-arg y))
1083     (foreground (required-arg foreground))
1084     (background (required-arg background)))
1085     (declare (type pixmap source) ;; required
1086     (type (or null pixmap) mask)
1087     (type card16 x y) ;; required
1088     (type (or null color) foreground background)) ;; required
1089 ram 1.3 (declare (clx-values cursor))
1090 ram 1.1 (let* ((display (pixmap-display source))
1091     (cursor (make-cursor :display display))
1092     (cid (allocate-resource-id display cursor 'cursor)))
1093     (setf (cursor-id cursor) cid)
1094 fgilham 1.8 (with-buffer-request (display +x-createcursor+)
1095 ram 1.1 (resource-id cid)
1096     (pixmap source)
1097     ((or null pixmap) mask)
1098     (rgb-val (color-red foreground)
1099     (color-green foreground)
1100     (color-blue foreground))
1101     (rgb-val (color-red background)
1102     (color-green background)
1103     (color-blue background))
1104     (card16 x y))
1105     cursor))
1106    
1107     (defun create-glyph-cursor (&key
1108     (source-font (required-arg source-font))
1109     (source-char (required-arg source-char))
1110     mask-font
1111     mask-char
1112     (foreground (required-arg foreground))
1113     (background (required-arg background)))
1114     (declare (type font source-font) ;; Required
1115     (type card16 source-char) ;; Required
1116     (type (or null font) mask-font)
1117     (type (or null card16) mask-char)
1118     (type color foreground background)) ;; required
1119 ram 1.3 (declare (clx-values cursor))
1120 ram 1.1 (let* ((display (font-display source-font))
1121     (cursor (make-cursor :display display))
1122     (cid (allocate-resource-id display cursor 'cursor))
1123     (source-font-id (font-id source-font))
1124     (mask-font-id (if mask-font (font-id mask-font) 0)))
1125     (setf (cursor-id cursor) cid)
1126     (unless mask-char (setq mask-char 0))
1127 fgilham 1.8 (with-buffer-request (display +x-createglyphcursor+)
1128 ram 1.1 (resource-id cid source-font-id mask-font-id)
1129     (card16 source-char)
1130     (card16 mask-char)
1131     (rgb-val (color-red foreground)
1132     (color-green foreground)
1133     (color-blue foreground))
1134     (rgb-val (color-red background)
1135     (color-green background)
1136     (color-blue background)))
1137     cursor))
1138    
1139     (defun free-cursor (cursor)
1140     (declare (type cursor cursor))
1141     (let ((display (cursor-display cursor)))
1142 fgilham 1.8 (with-buffer-request (display +x-freecursor+)
1143 ram 1.1 (cursor cursor))
1144     (deallocate-resource-id display (cursor-id cursor) 'cursor)))
1145    
1146     (defun recolor-cursor (cursor foreground background)
1147     (declare (type cursor cursor)
1148     (type color foreground background))
1149 fgilham 1.8 (with-buffer-request ((cursor-display cursor) +x-recolorcursor+)
1150 ram 1.1 (cursor cursor)
1151     (rgb-val (color-red foreground)
1152     (color-green foreground)
1153     (color-blue foreground))
1154     (rgb-val (color-red background)
1155     (color-green background)
1156     (color-blue background))
1157     ))
1158    
1159     (defun query-best-cursor (width height drawable)
1160     (declare (type card16 width height)
1161     (type (or drawable display) drawable))
1162 ram 1.3 (declare (clx-values width height))
1163 ram 1.1 ;; Drawable can be a display for compatibility.
1164     (multiple-value-bind (display drawable)
1165     (if (type? drawable 'drawable)
1166     (values (drawable-display drawable) drawable)
1167     (values drawable (screen-root (display-default-screen drawable))))
1168 fgilham 1.8 (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16)
1169 ram 1.1 ((data 0)
1170     (window drawable)
1171     (card16 width height))
1172     (values
1173     (card16-get 8)
1174     (card16-get 10)))))
1175    
1176     (defun query-best-tile (width height drawable)
1177     (declare (type card16 width height)
1178     (type drawable drawable))
1179 ram 1.3 (declare (clx-values width height))
1180 ram 1.1 (let ((display (drawable-display drawable)))
1181 fgilham 1.8 (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16)
1182 ram 1.1 ((data 1)
1183     (drawable drawable)
1184     (card16 width height))
1185     (values
1186     (card16-get 8)
1187     (card16-get 10)))))
1188    
1189     (defun query-best-stipple (width height drawable)
1190     (declare (type card16 width height)
1191     (type drawable drawable))
1192 ram 1.3 (declare (clx-values width height))
1193 ram 1.1 (let ((display (drawable-display drawable)))
1194 fgilham 1.8 (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16)
1195 ram 1.1 ((data 2)
1196     (drawable drawable)
1197     (card16 width height))
1198     (values
1199     (card16-get 8)
1200     (card16-get 10)))))
1201    
1202     (defun query-extension (display name)
1203     (declare (type display display)
1204     (type stringable name))
1205 ram 1.3 (declare (clx-values major-opcode first-event first-error))
1206 ram 1.1 (let ((string (string name)))
1207 fgilham 1.8 (with-buffer-request-and-reply (display +x-queryextension+ 12 :sizes 8)
1208 ram 1.1 ((card16 (length string))
1209     (pad16 nil)
1210     (string string))
1211     (and (boolean-get 8) ;; If present
1212     (values
1213     (card8-get 9)
1214     (card8-get 10)
1215     (card8-get 11))))))
1216    
1217     (defun list-extensions (display &key (result-type 'list))
1218     (declare (type display display)
1219     (type t result-type)) ;; CL type
1220 ram 1.3 (declare (clx-values (clx-sequence string)))
1221 fgilham 1.8 (with-buffer-request-and-reply (display +x-listextensions+ size :sizes 8)
1222 ram 1.1 ()
1223     (values
1224     (read-sequence-string
1225 fgilham 1.8 buffer-bbuf (index- size +replysize+) (card8-get 1) result-type +replysize+))))
1226 ram 1.1
1227     (defun change-keyboard-control (display &key key-click-percent
1228     bell-percent bell-pitch bell-duration
1229     led led-mode key auto-repeat-mode)
1230     (declare (type display display)
1231     (type (or null (member :default) int16) key-click-percent
1232     bell-percent bell-pitch bell-duration)
1233     (type (or null card8) led key)
1234     (type (or null (member :on :off)) led-mode)
1235     (type (or null (member :on :off :default)) auto-repeat-mode))
1236     (when (eq key-click-percent :default) (setq key-click-percent -1))
1237     (when (eq bell-percent :default) (setq bell-percent -1))
1238     (when (eq bell-pitch :default) (setq bell-pitch -1))
1239     (when (eq bell-duration :default) (setq bell-duration -1))
1240 fgilham 1.8 (with-buffer-request (display +x-changekeyboardcontrol+ :sizes (32))
1241 ram 1.1 (mask
1242     (integer key-click-percent bell-percent bell-pitch bell-duration)
1243     (card32 led)
1244     ((member :off :on) led-mode)
1245     (card32 key)
1246     ((member :off :on :default) auto-repeat-mode))))
1247    
1248     (defun keyboard-control (display)
1249     (declare (type display display))
1250 ram 1.3 (declare (clx-values key-click-percent bell-percent bell-pitch bell-duration
1251 ram 1.1 led-mask global-auto-repeat auto-repeats))
1252 fgilham 1.8 (with-buffer-request-and-reply (display +x-getkeyboardcontrol+ 32 :sizes (8 16 32))
1253 ram 1.1 ()
1254     (values
1255     (card8-get 12)
1256     (card8-get 13)
1257     (card16-get 14)
1258     (card16-get 16)
1259     (card32-get 8)
1260     (member8-get 1 :off :on)
1261 fgilham 1.8 (bit-vector256-get 20))))
1262 ram 1.1
1263     ;; The base volume should
1264     ;; be considered to be the "desired" volume in the normal case; that is, a
1265     ;; typical application should call XBell with 0 as the percent. Rather
1266     ;; than using a simple sum, the percent argument is instead used as the
1267     ;; percentage of the remaining range to alter the base volume by. That is,
1268     ;; the actual volume is:
1269     ;; if percent>=0: base - [(base * percent) / 100] + percent
1270     ;; if percent<0: base + [(base * percent) / 100]
1271    
1272     (defun bell (display &optional (percent-from-normal 0))
1273     ;; It is assumed that an eventual audio extension to X will provide more complete control.
1274     (declare (type display display)
1275     (type int8 percent-from-normal))
1276 fgilham 1.8 (with-buffer-request (display +x-bell+)
1277 ram 1.1 (data (int8->card8 percent-from-normal))))
1278    
1279     (defun pointer-mapping (display &key (result-type 'list))
1280     (declare (type display display)
1281     (type t result-type)) ;; CL type
1282 ram 1.3 (declare (clx-values sequence)) ;; Sequence of card
1283 fgilham 1.8 (with-buffer-request-and-reply (display +x-getpointermapping+ nil :sizes 8)
1284 ram 1.1 ()
1285     (values
1286     (sequence-get :length (card8-get 1) :result-type result-type :format card8
1287 fgilham 1.8 :index +replysize+))))
1288 ram 1.1
1289     (defun set-pointer-mapping (display map)
1290     ;; Can signal device-busy.
1291     (declare (type display display)
1292     (type sequence map)) ;; Sequence of card8
1293 fgilham 1.8 (when (with-buffer-request-and-reply (display +x-setpointermapping+ 2 :sizes 8)
1294 ram 1.1 ((data (length map))
1295     ((sequence :format card8) map))
1296     (values
1297     (boolean-get 1)))
1298     (x-error 'device-busy :display display))
1299     map)
1300    
1301     (defsetf pointer-mapping set-pointer-mapping)
1302    
1303     (defun change-pointer-control (display &key acceleration threshold)
1304     ;; Acceleration is rationalized if necessary.
1305     (declare (type display display)
1306     (type (or null (member :default) number) acceleration)
1307 ram 1.3 (type (or null (member :default) integer) threshold))
1308 ram 1.1 (flet ((rationalize16 (number)
1309     ;; Rationalize NUMBER into the ratio of two signed 16 bit numbers
1310 ram 1.3 (declare (type number number))
1311     (declare (clx-values numerator denominator))
1312 ram 1.1 (do* ((rational (rationalize number))
1313     (numerator (numerator rational) (ash numerator -1))
1314     (denominator (denominator rational) (ash denominator -1)))
1315     ((or (= numerator 1)
1316     (and (< (abs numerator) #x8000)
1317     (< denominator #x8000)))
1318     (values
1319     numerator (min denominator #x7fff))))))
1320 ram 1.3 (declare (inline rationalize16))
1321 ram 1.1 (let ((acceleration-p 1)
1322     (threshold-p 1)
1323     (numerator 0)
1324     (denominator 1))
1325     (declare (type card8 acceleration-p threshold-p)
1326     (type int16 numerator denominator))
1327     (cond ((eq acceleration :default) (setq numerator -1))
1328     (acceleration (multiple-value-setq (numerator denominator)
1329     (rationalize16 acceleration)))
1330     (t (setq acceleration-p 0)))
1331     (cond ((eq threshold :default) (setq threshold -1))
1332     ((null threshold) (setq threshold -1
1333     threshold-p 0)))
1334 fgilham 1.8 (with-buffer-request (display +x-changepointercontrol+)
1335 ram 1.1 (int16 numerator denominator threshold)
1336     (card8 acceleration-p threshold-p)))))
1337    
1338     (defun pointer-control (display)
1339     (declare (type display display))
1340 ram 1.3 (declare (clx-values acceleration threshold))
1341 fgilham 1.8 (with-buffer-request-and-reply (display +x-getpointercontrol+ 16 :sizes 16)
1342 ram 1.1 ()
1343     (values
1344 ram 1.3 (/ (card16-get 8) (card16-get 10)) ; Should we float this?
1345     (card16-get 12))))
1346 ram 1.1
1347     (defun set-screen-saver (display timeout interval blanking exposures)
1348     ;; Timeout and interval are in seconds, will be rounded to minutes.
1349     (declare (type display display)
1350     (type (or (member :default) int16) timeout interval)
1351     (type (member :on :off :default :yes :no) blanking exposures))
1352     (case blanking (:yes (setq blanking :on)) (:no (setq blanking :off)))
1353     (case exposures (:yes (setq exposures :on)) (:no (setq exposures :off)))
1354     (when (eq timeout :default) (setq timeout -1))
1355     (when (eq interval :default) (setq interval -1))
1356 fgilham 1.8 (with-buffer-request (display +x-setscreensaver+)
1357 ram 1.1 (int16 timeout interval)
1358     ((member8 :on :off :default) blanking exposures)))
1359    
1360     (defun screen-saver (display)
1361     ;; Returns timeout and interval in seconds.
1362     (declare (type display display))
1363 ram 1.3 (declare (clx-values timeout interval blanking exposures))
1364 fgilham 1.8 (with-buffer-request-and-reply (display +x-getscreensaver+ 14 :sizes (8 16))
1365 ram 1.1 ()
1366     (values
1367     (card16-get 8)
1368     (card16-get 10)
1369     (member8-get 12 :on :off :default)
1370     (member8-get 13 :on :off :default))))
1371    
1372     (defun activate-screen-saver (display)
1373     (declare (type display display))
1374 fgilham 1.8 (with-buffer-request (display +x-forcescreensaver+)
1375 ram 1.1 (data 1)))
1376    
1377     (defun reset-screen-saver (display)
1378     (declare (type display display))
1379 fgilham 1.8 (with-buffer-request (display +x-forcescreensaver+)
1380 ram 1.1 (data 0)))
1381    
1382     (defun add-access-host (display host &optional (family :internet))
1383     ;; A string must be acceptable as a host, but otherwise the possible types for
1384     ;; host are not constrained, and will likely be very system dependent.
1385     ;; This implementation uses a list whose car is the family keyword
1386     ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes.
1387     (declare (type display display)
1388     (type (or stringable list) host)
1389     (type (or null (member :internet :decnet :chaos) card8) family))
1390     (change-access-host display host family nil))
1391    
1392     (defun remove-access-host (display host &optional (family :internet))
1393     ;; A string must be acceptable as a host, but otherwise the possible types for
1394     ;; host are not constrained, and will likely be very system dependent.
1395     ;; This implementation uses a list whose car is the family keyword
1396     ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes.
1397     (declare (type display display)
1398     (type (or stringable list) host)
1399     (type (or null (member :internet :decnet :chaos) card8) family))
1400     (change-access-host display host family t))
1401    
1402     (defun change-access-host (display host family remove-p)
1403     (declare (type display display)
1404     (type (or stringable list) host)
1405     (type (or null (member :internet :decnet :chaos) card8) family))
1406     (unless (consp host)
1407     (setq host (host-address host family)))
1408     (let ((family (car host))
1409     (address (cdr host)))
1410 fgilham 1.8 (with-buffer-request (display +x-changehosts+)
1411 ram 1.1 ((data boolean) remove-p)
1412     (card8 (encode-type (or null (member :internet :decnet :chaos) card32) family))
1413     (card16 (length address))
1414     ((sequence :format card8) address))))
1415    
1416     (defun access-hosts (display &optional (result-type 'list))
1417     ;; The type of host objects returned is not constrained, except that the hosts must
1418     ;; be acceptable to add-access-host and remove-access-host.
1419     ;; This implementation uses a list whose car is the family keyword
1420     ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes.
1421     (declare (type display display)
1422     (type t result-type)) ;; CL type
1423 ram 1.3 (declare (clx-values (clx-sequence host) enabled-p))
1424 fgilham 1.8 (with-buffer-request-and-reply (display +x-listhosts+ nil :sizes (8 16))
1425 ram 1.1 ()
1426     (let* ((enabled-p (boolean-get 1))
1427     (nhosts (card16-get 8))
1428     (sequence (make-sequence result-type nhosts)))
1429 fgilham 1.8 (advance-buffer-offset +replysize+)
1430 ram 1.1 (dotimes (i nhosts)
1431     (let ((family (card8-get 0))
1432     (len (card16-get 2)))
1433     (setf (elt sequence i)
1434     (cons (if (< family 3)
1435     (svref '#(:internet :decnet :chaos) family)
1436     family)
1437     (sequence-get :length len :format card8 :result-type 'list
1438     :index (+ buffer-boffset 4))))
1439     (advance-buffer-offset (+ 4 (* 4 (ceiling len 4))))))
1440     (values
1441     sequence
1442     enabled-p))))
1443    
1444     (defun access-control (display)
1445     (declare (type display display))
1446 dtc 1.4 (declare (clx-values generalized-boolean)) ;; True when access-control is ENABLED
1447 fgilham 1.8 (with-buffer-request-and-reply (display +x-listhosts+ 2 :sizes 8)
1448 ram 1.1 ()
1449     (boolean-get 1)))
1450    
1451     (defun set-access-control (display enabled-p)
1452     (declare (type display display)
1453 dtc 1.4 (type generalized-boolean enabled-p))
1454 fgilham 1.8 (with-buffer-request (display +x-changeaccesscontrol+)
1455 ram 1.1 ((data boolean) enabled-p))
1456     enabled-p)
1457    
1458     (defsetf access-control set-access-control)
1459    
1460     (defun close-down-mode (display)
1461     ;; setf'able
1462     ;; Cached locally in display object.
1463     (declare (type display display))
1464 ram 1.3 (declare (clx-values (member :destroy :retain-permanent :retain-temporary nil)))
1465 ram 1.1 (display-close-down-mode display))
1466    
1467     (defun set-close-down-mode (display mode)
1468     ;; Cached locally in display object.
1469     (declare (type display display)
1470     (type (member :destroy :retain-permanent :retain-temporary) mode))
1471     (setf (display-close-down-mode display) mode)
1472 fgilham 1.8 (with-buffer-request (display +x-changeclosedownmode+ :sizes (32))
1473 ram 1.1 ((data (member :destroy :retain-permanent :retain-temporary)) mode))
1474     mode)
1475    
1476     (defsetf close-down-mode set-close-down-mode)
1477    
1478     (defun kill-client (display resource-id)
1479     (declare (type display display)
1480     (type resource-id resource-id))
1481 fgilham 1.8 (with-buffer-request (display +x-killclient+)
1482 ram 1.1 (resource-id resource-id)))
1483    
1484     (defun kill-temporary-clients (display)
1485     (declare (type display display))
1486 fgilham 1.8 (with-buffer-request (display +x-killclient+)
1487 ram 1.1 (resource-id 0)))
1488    
1489     (defun no-operation (display)
1490     (declare (type display display))
1491 fgilham 1.8 (with-buffer-request (display +x-nooperation+)))

  ViewVC Help
Powered by ViewVC 1.1.5