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

Contents of /src/clx/requests.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5