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

Contents of /src/clx/display.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.16 - (show annotations)
Tue Nov 16 19:13:55 2010 UTC (3 years, 5 months ago) by rtoy
Branch: MAIN
CVS Tags: GIT-CONVERSION, cross-sol-x86-merged, cross-sol-x86-base, snapshot-2010-12, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, cross-sol-x86-2010-12-20, HEAD
Branch point for: cross-sol-x86-branch
Changes since 1.15: +4 -2 lines
GET-BEST-AUTHORIZATION wasn't handling the case of a :local connection
where the xauth file only contained one entry for localhost/unix:0.
When the protocol is :local, we explicitly check for localhost.
Previously, the host-address was converted the hostname, which isn't
"localhost".
1 ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
2
3 ;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11
4
5 ;;;
6 ;;; TEXAS INSTRUMENTS INCORPORATED
7 ;;; P.O. BOX 2909
8 ;;; AUSTIN, TEXAS 78769
9 ;;;
10 ;;; Copyright (C) 1987 Texas Instruments Incorporated.
11 ;;;
12 ;;; Permission is granted to any individual or institution to use, copy, modify,
13 ;;; and distribute this software, provided that this complete copyright and
14 ;;; permission notice is maintained, intact, in all copies and supporting
15 ;;; documentation.
16 ;;;
17 ;;; Texas Instruments Incorporated provides this software "as is" without
18 ;;; express or implied warranty.
19 ;;;
20
21 #+cmu
22 (ext:file-comment "$Id: display.lisp,v 1.16 2010/11/16 19:13:55 rtoy Exp $")
23
24 (in-package :xlib)
25
26 ;;; Authorizaton
27
28 (defparameter *known-authorizations* '("MIT-MAGIC-COOKIE-1"))
29
30 ;;; X11 Authorization: to prevent malicious users from snooping on a
31 ;;; display, X servers may require connection requests to be
32 ;;; authorized. The X server (or display manager) will create a random
33 ;;; key on startup, and store it as an entry in a file generally named
34 ;;; $HOME/.Xauthority (see xauth(1) and the AUTHORITY-PATHNAME
35 ;;; function). Clients must extract from this file the "magic cookie"
36 ;;; that corresponds to the server they wish to connect to, and send
37 ;;; it as authorization data when opening the display.
38
39 ;;; The format of the .Xauthority file is documented in the XFree
40 ;;; sources, in the file xc/lib/Xau/README.
41
42 ;;; Stolen from the cmucl sources, with patches by Hannu Rummukainen and
43 ;;; Scott Fahlman.
44
45 (defun read-xauth-entry (stream)
46 (labels ((read-short (stream &optional (eof-errorp t))
47 (let ((high-byte (read-byte stream eof-errorp)))
48 (and high-byte
49 (dpb high-byte (byte 8 8) (read-byte stream)))))
50 (read-short-length-string (stream)
51 (let ((length (read-short stream)))
52 (let ((string (make-string length)))
53 (dotimes (k length)
54 (setf (schar string k) (card8->char (read-byte stream))))
55 string)))
56 (read-short-length-vector (stream)
57 (let ((length (read-short stream)))
58 (let ((vector (make-array length
59 :element-type '(unsigned-byte 8))))
60 (dotimes (k length)
61 (setf (aref vector k) (read-byte stream)))
62 vector))))
63 (let ((family-id (read-short stream nil)))
64 (if (null family-id)
65 (list nil nil nil nil nil)
66 (let* ((address-data (read-short-length-vector stream))
67 (number (parse-integer (read-short-length-string stream)))
68 (name (read-short-length-string stream))
69 (data (read-short-length-vector stream))
70 (family (car (rassoc family-id *protocol-families*))))
71 (unless family
72 (return-from read-xauth-entry
73 ;; we return FAMILY-ID to signal to
74 ;; GET-BEST-AUTHORIZATION that we haven't finished
75 ;; with the stream.
76 (list family-id nil nil nil nil)))
77 (let ((address
78 (case family
79 (:local (map 'string #'code-char address-data))
80 (:internet (coerce address-data 'list))
81 ;; FIXME: we can probably afford not to support
82 ;; :DECNET or :CHAOSNET in this modern age, but
83 ;; :INTERNET6 probably deserve support. -- CSR,
84 ;; 2005-08-07
85 (t nil))))
86 ;; if ADDRESS is NIL by this time, we will never match
87 ;; the address of DISPLAY.
88 (list family address number name data)))))))
89
90 (defun get-best-authorization (host display protocol)
91 ;; parse .Xauthority, extract the cookie for DISPLAY on HOST.
92 ;; PROTOCOL determines whether the server connection is using an
93 ;; Internet protocol (value of :internet) or a non-network
94 ;; protocol such as Unix domain sockets (value of :local). Returns
95 ;; two strings: an authorization name (very likely the string
96 ;; "MIT-MAGIC-COOKIE-1") and an authorization key, represented as
97 ;; fixnums in a vector. If we fail to find an appropriate cookie,
98 ;; return two empty strings.
99 (let ((pathname (authority-pathname)))
100 (when pathname
101 (with-open-file (stream pathname :element-type '(unsigned-byte 8)
102 :if-does-not-exist nil)
103 (when stream
104 (let* ((host-address (and (eql protocol :internet)
105 (rest (host-address host protocol))))
106 (best-name nil) (best-pos nil)
107 (best-data nil))
108 ;; Check for the localhost address, in which case we're
109 ;; really FamilyLocal.
110 (when (or (eql protocol :local)
111 (and (eql protocol :internet)
112 (equal host-address '(127 0 0 1))))
113 (setq host-address (get-host-name))
114 (setq protocol :local))
115 (loop
116 (destructuring-bind (family address number name data)
117 (read-xauth-entry stream)
118 (unless family (return))
119 (when (and (eql family protocol)
120 (or (equal host-address address)
121 (and (eql family :local)
122 (equal address "localhost")))
123 (= number display)
124 (let ((pos1 (position name *known-authorizations*
125 :test #'string=)))
126 (and pos1
127 (or (null best-pos)
128 (< pos1 best-pos)))))
129 (setf best-name name
130 best-pos (position name *known-authorizations*
131 :test #'string=)
132 best-data data))))
133 (when best-name
134 (return-from get-best-authorization
135 (values best-name best-data)))))))
136 (values "" "")))
137
138 (defmacro with-display ((display &key timeout inline)
139 &body body)
140 ;; This macro is for use in a multi-process environment. It
141 ;; provides exclusive access to the local display object for
142 ;; multiple request generation. It need not provide immediate
143 ;; exclusive access for replies; that is, if another process is
144 ;; waiting for a reply (while not in a with-display), then
145 ;; synchronization need not (but can) occur immediately. Except
146 ;; where noted, all routines effectively contain an implicit
147 ;; with-display where needed, so that correct synchronization is
148 ;; always provided at the interface level on a per-call basis.
149 ;; Nested uses of this macro will work correctly. This macro does
150 ;; not prevent concurrent event processing; see with-event-queue.
151 `(with-buffer (,display
152 ,@(and timeout `(:timeout ,timeout))
153 ,@(and inline `(:inline ,inline)))
154 ,@body))
155
156 ;;
157 ;; Resource id management
158 ;;
159 (defun initialize-resource-allocator (display)
160 ;; Find the resource-id-byte (appropriate for LDB & DPB) from the resource-id-mask
161 (let ((id-mask (display-resource-id-mask display)))
162 (unless (zerop id-mask) ;; zero mask is an error
163 (do ((first 0 (index1+ first))
164 (mask id-mask (the mask32 (ash mask -1))))
165 ((oddp mask)
166 (setf (display-resource-id-byte display)
167 (byte (integer-length mask) first)))
168 (declare (type array-index first)
169 (type mask32 mask))))))
170
171 (defun resourcealloc (display)
172 ;; Allocate a resource-id for use in DISPLAY
173 (declare (type display display))
174 (declare (clx-values resource-id))
175 (loop for next-count upfrom (1+ (display-resource-id-count display))
176 repeat (1+ (display-resource-id-mask display))
177 as id = (dpb next-count
178 (display-resource-id-byte display)
179 (display-resource-id-base display))
180 unless (nth-value 1 (gethash id (display-resource-id-map display)))
181 do (setf (display-resource-id-count display) next-count)
182 (setf (gethash id (display-resource-id-map display)) t)
183 (return-from resourcealloc id))
184 ;; internal consistency check
185 (assert (= (hash-table-count (display-resource-id-map display))
186 (1+ (display-resource-id-mask display))))
187 ;; tell the user what's gone wrong
188 (error 'resource-ids-exhausted))
189
190 (defmacro allocate-resource-id (display object type)
191 ;; Allocate a resource-id for OBJECT in DISPLAY
192 `(with-display (,display)
193 ,(if (member (eval type) +clx-cached-types+)
194 `(let ((id (funcall (display-xid ,display) ,display)))
195 (save-id ,display id ,object)
196 id)
197 `(funcall (display-xid ,display) ,display))))
198
199 (defmacro deallocate-resource-id (display id type)
200 (declare (ignore type))
201 ;; Deallocate a resource-id for OBJECT in DISPLAY
202 `(deallocate-resource-id-internal ,display ,id))
203
204 (defun deallocate-resource-id-internal (display id)
205 (with-display (display)
206 (remhash id (display-resource-id-map display))))
207
208 (defun lookup-resource-id (display id)
209 ;; Find the object associated with resource ID
210 (gethash id (display-resource-id-map display)))
211
212 (defun save-id (display id object)
213 ;; cache the object associated with ID for this display.
214 (declare (type display display)
215 (type integer id)
216 (type t object))
217 (declare (clx-values object))
218 ;; we can't cache objects from other clients, because they may
219 ;; become invalid without us being told about that.
220 (let ((base (display-resource-id-base display))
221 (mask (display-resource-id-mask display)))
222 (when (= (logandc2 id mask) base)
223 (setf (gethash id (display-resource-id-map display)) object))
224 object))
225
226 ;; Define functions to find the CLX data types given a display and resource-id
227 ;; If the data type is being cached, look there first.
228 (macrolet ((generate-lookup-functions (useless-name &body types)
229 `(within-definition (,useless-name generate-lookup-functions)
230 ,@(mapcar
231 #'(lambda (type)
232 `(defun ,(xintern 'lookup- type)
233 (display id)
234 (declare (type display display)
235 (type resource-id id))
236 (declare (clx-values ,type))
237 ,(if (member type +clx-cached-types+)
238 `(let ((,type (lookup-resource-id display id)))
239 (cond ((null ,type) ;; Not found, create and save it.
240 (setq ,type (,(xintern 'make- type)
241 :display display :id id))
242 (save-id display id ,type))
243 ;; Found. Check the type
244 ,(cond ((null +type-check?+)
245 `(t ,type))
246 ((member type '(window pixmap))
247 `((type? ,type 'drawable) ,type))
248 (t `((type? ,type ',type) ,type)))
249 ,@(when +type-check?+
250 `((t (x-error 'lookup-error
251 :id id
252 :display display
253 :type ',type
254 :object ,type))))))
255 ;; Not being cached. Create a new one each time.
256 `(,(xintern 'make- type)
257 :display display :id id))))
258 types))))
259 (generate-lookup-functions ignore
260 drawable
261 window
262 pixmap
263 gcontext
264 cursor
265 colormap
266 font))
267
268 (defun id-atom (id display)
269 ;; Return the cached atom for an atom ID
270 (declare (type resource-id id)
271 (type display display))
272 (declare (clx-values (or null keyword)))
273 (gethash id (display-atom-id-map display)))
274
275 (defun atom-id (atom display)
276 ;; Return the ID for an atom in DISPLAY
277 (declare (type xatom atom)
278 (type display display))
279 (declare (clx-values (or null resource-id)))
280 (gethash (if (or (null atom) (keywordp atom)) atom (kintern atom))
281 (display-atom-cache display)))
282
283 (defun set-atom-id (atom display id)
284 ;; Set the ID for an atom in DISPLAY
285 (declare (type xatom atom)
286 (type display display)
287 (type resource-id id))
288 (declare (clx-values resource-id))
289 (let ((atom (if (or (null atom) (keywordp atom)) atom (kintern atom))))
290 (setf (gethash id (display-atom-id-map display)) atom)
291 (setf (gethash atom (display-atom-cache display)) id)
292 id))
293
294 (defsetf atom-id set-atom-id)
295
296 (defun initialize-predefined-atoms (display)
297 (dotimes (i (length +predefined-atoms+))
298 (declare (type resource-id i))
299 (setf (atom-id (svref +predefined-atoms+ i) display) i)))
300
301 (defun visual-info (display visual-id)
302 (declare (type display display)
303 (type resource-id visual-id)
304 (clx-values visual-info))
305 (when (zerop visual-id)
306 (return-from visual-info nil))
307 (dolist (screen (display-roots display))
308 (declare (type screen screen))
309 (dolist (depth (screen-depths screen))
310 (declare (type cons depth))
311 (dolist (visual-info (rest depth))
312 (declare (type visual-info visual-info))
313 (when (funcall (resource-id-map-test) visual-id (visual-info-id visual-info))
314 (return-from visual-info visual-info)))))
315 (error "Visual info not found for id #x~x in display ~s." visual-id display))
316
317
318 ;;
319 ;; Display functions
320 ;;
321 (defmacro with-event-queue ((display &key timeout inline)
322 &body body &environment env)
323 ;; exclusive access to event queue
324 `(macrolet ((with-event-queue ((display &key timeout) &body body)
325 ;; Speedup hack for lexically nested with-event-queues
326 `(progn
327 (progn ,display ,@(and timeout `(,timeout)) nil)
328 ,@body)))
329 ,(if (and (null inline) (macroexpand '(use-closures) env))
330 `(flet ((.with-event-queue-body. () ,@body))
331 #+clx-ansi-common-lisp
332 (declare (dynamic-extent #'.with-event-queue-body.))
333 (with-event-queue-function
334 ,display ,timeout #'.with-event-queue-body.))
335 (let ((disp (if (or (symbolp display) (constantp display))
336 display
337 '.display.)))
338 `(let (,@(unless (eq disp display) `((,disp ,display))))
339 (holding-lock ((display-event-lock ,disp) ,disp "CLX Event Lock"
340 ,@(and timeout `(:timeout ,timeout)))
341 ,@body))))))
342
343 (defun with-event-queue-function (display timeout function)
344 (declare (type display display)
345 (type (or null number) timeout)
346 (type function function)
347 #+clx-ansi-common-lisp
348 (dynamic-extent function)
349 ;; FIXME: see SBCL bug #243
350 (ignorable display timeout)
351 #+(and lispm (not clx-ansi-common-lisp))
352 (sys:downward-funarg function))
353 (with-event-queue (display :timeout timeout :inline t)
354 (funcall function)))
355
356 (defmacro with-event-queue-internal ((display &key timeout) &body body)
357 ;; exclusive access to the internal event queues
358 (let ((disp (if (or (symbolp display) (constantp display)) display '.display.)))
359 `(let (,@(unless (eq disp display) `((,disp ,display))))
360 (holding-lock ((display-event-queue-lock ,disp) ,disp "CLX Event Queue Lock"
361 ,@(and timeout `(:timeout ,timeout)))
362 ,@body))))
363
364 (defun open-default-display (&optional display-name)
365 "Open a connection to DISPLAY-NAME if supplied, or to the appropriate
366 default display as given by GET-DEFAULT-DISPLAY otherwise.
367
368 OPEN-DISPLAY-NAME always attempts to do display authorization. The
369 hostname is resolved to an address, then authorization data for the
370 (protocol, host-address, displaynumber) triple is looked up in the
371 file given by AUTHORITY_PATHNAME (typically $HOME/.Xauthority). If
372 the protocol is :local, or if the hostname resolves to the local host,
373 authority data for the local machine's actual hostname - as returned by
374 gethostname(3) - is used instead."
375 (destructuring-bind (host display screen protocol)
376 (get-default-display display-name)
377 (let ((display (open-display host :display display :protocol protocol)))
378 (setf (display-default-screen display) (nth screen (display-roots display)))
379 display)))
380
381 (defun open-display (host &key (display 0) protocol authorization-name authorization-data)
382 ;; Implementation specific routine to setup the buffer for a
383 ;; specific host and display. This must interface with the local
384 ;; network facilities, and will probably do special things to
385 ;; circumvent the nework when displaying on the local host.
386 ;;
387 ;; A string must be acceptable as a host, but otherwise the possible types
388 ;; for host and protocol are not constrained, and will likely be very
389 ;; system dependent. The default protocol is system specific. Authorization,
390 ;; if any, is assumed to come from the environment somehow.
391 (declare (type integer display))
392 (declare (clx-values display))
393 (let ((protocol
394 (if (member host '("" "unix") :test #'equal)
395 :local
396 protocol)))
397 ;; Get the authorization mechanism from the environment. Handle the
398 ;; special case of a host name of "" and "unix" which means the
399 ;; protocol is :local
400 (when (null authorization-name)
401 (multiple-value-setq (authorization-name authorization-data)
402 (get-best-authorization host display protocol)))
403 ;; PROTOCOL is the network protocol (something like :TCP :DNA or :CHAOS). See OPEN-X-STREAM.
404 (let* ((stream (open-x-stream host display protocol))
405 (disp (make-buffer *output-buffer-size* #'make-display-internal
406 :host host :display display
407 :output-stream stream :input-stream stream))
408 (ok-p nil))
409 (unwind-protect
410 (progn
411 (display-connect disp
412 :authorization-name authorization-name
413 :authorization-data authorization-data)
414 (setf (display-authorization-name disp) authorization-name)
415 (setf (display-authorization-data disp) authorization-data)
416 (initialize-resource-allocator disp)
417 (initialize-predefined-atoms disp)
418 (initialize-extensions disp)
419 (when (assoc "BIG-REQUESTS" (display-extension-alist disp)
420 :test #'string=)
421 (enable-big-requests disp))
422 (setq ok-p t))
423 (unless ok-p (close-display disp :abort t)))
424 disp)))
425
426 (defun display-force-output (display)
427 ; Output is normally buffered, this forces any buffered output to the server.
428 (declare (type display display))
429 (with-display (display)
430 (buffer-force-output display)))
431
432 (defun close-display (display &key abort)
433 ;; Close the host connection in DISPLAY
434 (declare (type display display))
435 (close-buffer display :abort abort))
436
437 (defun display-connect (display &key authorization-name authorization-data)
438 (with-buffer-output (display :sizes (8 16))
439 (card8-put
440 0
441 (ecase (display-byte-order display)
442 (:lsbfirst #x6c) ;; Ascii lowercase l - Least Significant Byte First
443 (:msbfirst #x42))) ;; Ascii uppercase B - Most Significant Byte First
444 (card16-put 2 *protocol-major-version*)
445 (card16-put 4 *protocol-minor-version*)
446 (card16-put 6 (length authorization-name))
447 (card16-put 8 (length authorization-data))
448 (write-sequence-char display 12 authorization-name)
449 (if (stringp authorization-data)
450 (write-sequence-char display (lround (+ 12 (length authorization-name)))
451 authorization-data)
452 (write-sequence-card8 display (lround (+ 12 (length authorization-name)))
453 authorization-data)))
454 (buffer-force-output display)
455 (let ((reply-buffer nil))
456 (declare (type (or null reply-buffer) reply-buffer))
457 (unwind-protect
458 (progn
459 (setq reply-buffer (allocate-reply-buffer #x1000))
460 (with-buffer-input (reply-buffer :sizes (8 16 32))
461 (buffer-input display buffer-bbuf 0 8)
462 (let ((success (boolean-get 0))
463 (reason-length (card8-get 1))
464 (major-version (card16-get 2))
465 (minor-version (card16-get 4))
466 (total-length (card16-get 6))
467 vendor-length
468 num-roots
469 num-formats)
470 (declare (ignore total-length))
471 (unless success
472 (x-error 'connection-failure
473 :major-version major-version
474 :minor-version minor-version
475 :host (display-host display)
476 :display (display-display display)
477 :reason
478 (progn (buffer-input display buffer-bbuf 0 reason-length)
479 (string-get reason-length 0 :reply-buffer reply-buffer))))
480 (buffer-input display buffer-bbuf 0 32)
481 (setf (display-protocol-major-version display) major-version)
482 (setf (display-protocol-minor-version display) minor-version)
483 (setf (display-release-number display) (card32-get 0))
484 (setf (display-resource-id-base display) (card32-get 4))
485 (setf (display-resource-id-mask display) (card32-get 8))
486 (setf (display-motion-buffer-size display) (card32-get 12))
487 (setq vendor-length (card16-get 16))
488 (setf (display-max-request-length display) (card16-get 18))
489 (setq num-roots (card8-get 20))
490 (setq num-formats (card8-get 21))
491 ;; Get the image-info
492 (setf (display-image-lsb-first-p display) (zerop (card8-get 22)))
493 (let ((format (display-bitmap-format display)))
494 (declare (type bitmap-format format))
495 (setf (bitmap-format-lsb-first-p format) (zerop (card8-get 23)))
496 (setf (bitmap-format-unit format) (card8-get 24))
497 (setf (bitmap-format-pad format) (card8-get 25)))
498 (setf (display-min-keycode display) (card8-get 26))
499 (setf (display-max-keycode display) (card8-get 27))
500 ;; 4 bytes unused
501 ;; Get the vendor string
502 (buffer-input display buffer-bbuf 0 (lround vendor-length))
503 (setf (display-vendor-name display)
504 (string-get vendor-length 0 :reply-buffer reply-buffer))
505 ;; Initialize the pixmap formats
506 (dotimes (i num-formats) ;; loop gathering pixmap formats
507 (declare (ignorable i))
508 (buffer-input display buffer-bbuf 0 8)
509 (push (make-pixmap-format :depth (card8-get 0)
510 :bits-per-pixel (card8-get 1)
511 :scanline-pad (card8-get 2))
512 ; 5 unused bytes
513 (display-pixmap-formats display)))
514 (setf (display-pixmap-formats display)
515 (nreverse (display-pixmap-formats display)))
516 ;; Initialize the screens
517 (dotimes (i num-roots)
518 (declare (ignorable i))
519 (buffer-input display buffer-bbuf 0 40)
520 (let* ((root-id (card32-get 0))
521 (root (make-window :id root-id :display display))
522 (root-visual (card32-get 32))
523 (default-colormap-id (card32-get 4))
524 (default-colormap
525 (make-colormap :id default-colormap-id :display display))
526 (screen
527 (make-screen
528 :root root
529 :default-colormap default-colormap
530 :white-pixel (card32-get 8)
531 :black-pixel (card32-get 12)
532 :event-mask-at-open (card32-get 16)
533 :width (card16-get 20)
534 :height (card16-get 22)
535 :width-in-millimeters (card16-get 24)
536 :height-in-millimeters (card16-get 26)
537 :min-installed-maps (card16-get 28)
538 :max-installed-maps (card16-get 30)
539 :backing-stores (member8-get 36 :never :when-mapped :always)
540 :save-unders-p (boolean-get 37)
541 :root-depth (card8-get 38)))
542 (num-depths (card8-get 39))
543 (depths nil))
544 ;; Save root window for event reporting
545 (save-id display root-id root)
546 (save-id display default-colormap-id default-colormap)
547 ;; Create the depth AList for a screen, (depth . visual-infos)
548 (dotimes (j num-depths)
549 (declare (ignorable j))
550 (buffer-input display buffer-bbuf 0 8)
551 (let ((depth (card8-get 0))
552 (num-visuals (card16-get 2))
553 (visuals nil)) ;; 4 bytes unused
554 (dotimes (k num-visuals)
555 (declare (ignorable k))
556 (buffer-input display buffer-bbuf 0 24)
557 (let* ((visual (card32-get 0))
558 (visual-info (make-visual-info
559 :id visual
560 :display display
561 :class (member8-get 4 :static-gray :gray-scale
562 :static-color :pseudo-color
563 :true-color :direct-color)
564 :bits-per-rgb (card8-get 5)
565 :colormap-entries (card16-get 6)
566 :red-mask (card32-get 8)
567 :green-mask (card32-get 12)
568 :blue-mask (card32-get 16)
569 ;; 4 bytes unused
570 )))
571 (push visual-info visuals)
572 (when (funcall (resource-id-map-test) root-visual visual)
573 (setf (screen-root-visual-info screen)
574 (setf (colormap-visual-info default-colormap)
575 visual-info)))))
576 (push (cons depth (nreverse visuals)) depths)))
577 (setf (screen-depths screen) (nreverse depths))
578 (push screen (display-roots display))))
579 (setf (display-roots display) (nreverse (display-roots display)))
580 (setf (display-default-screen display) (first (display-roots display))))))
581 (when reply-buffer
582 (deallocate-reply-buffer reply-buffer))))
583 display)
584
585 (defun display-protocol-version (display)
586 (declare (type display display))
587 (declare (clx-values major minor))
588 (values (display-protocol-major-version display)
589 (display-protocol-minor-version display)))
590
591 (defun display-vendor (display)
592 (declare (type display display))
593 (declare (clx-values name release))
594 (values (display-vendor-name display)
595 (display-release-number display)))
596
597 (defun display-nscreens (display)
598 (declare (type display display))
599 (length (display-roots display)))
600
601 #+comment ;; defined by the DISPLAY defstruct
602 (defsetf display-error-handler (display) (handler)
603 ;; All errors (synchronous and asynchronous) are processed by
604 ;; calling an error handler in the display. If handler is a
605 ;; sequence it is expected to contain handler functions specific to
606 ;; each error; the error code is used to index the sequence,
607 ;; fetching the appropriate handler. Any results returned by the
608 ;; handler are ignored; it is assumed the handler either takes care
609 ;; of the error completely, or else signals. For all core errors,
610 ;; the keyword/value argument pairs are:
611 ;; :display display
612 ;; :error-key error-key
613 ;; :major integer
614 ;; :minor integer
615 ;; :sequence integer
616 ;; :current-sequence integer
617 ;; For :colormap, :cursor, :drawable, :font, :gcontext, :id-choice, :pixmap, and
618 ;; :window errors another pair is:
619 ;; :resource-id integer
620 ;; For :atom errors, another pair is:
621 ;; :atom-id integer
622 ;; For :value errors, another pair is:
623 ;; :value integer
624 )
625
626 ;; setf'able
627 ;; If defined, called after every protocol request is generated,
628 ;; even those inside explicit with-display's, but never called from
629 ;; inside the after-function itself. The function is called inside
630 ;; the effective with-display for the associated request. Default
631 ;; value is nil. Can be set, for example, to #'display-force-output
632 ;; or #'display-finish-output.
633
634 (defvar *inside-display-after-function* nil)
635
636 (defun display-invoke-after-function (display)
637 ; Called after every protocal request is generated
638 (declare (type display display))
639 (when (and (display-after-function display)
640 (not *inside-display-after-function*))
641 (let ((*inside-display-after-function* t)) ;; Ensure no recursive calls
642 (funcall (display-after-function display) display))))
643
644 (defun display-finish-output (display)
645 ;; Forces output, then causes a round-trip to ensure that all possible
646 ;; errors and events have been received.
647 (declare (type display display))
648 (with-buffer-request-and-reply (display +x-getinputfocus+ 16 :sizes (8 32))
649 ()
650 )
651 ;; Report asynchronous errors here if the user wants us to.
652 (report-asynchronous-errors display :after-finish-output))
653
654 (defparameter
655 *request-names*
656 '#("error" "CreateWindow" "ChangeWindowAttributes" "GetWindowAttributes"
657 "DestroyWindow" "DestroySubwindows" "ChangeSaveSet" "ReparentWindow"
658 "MapWindow" "MapSubwindows" "UnmapWindow" "UnmapSubwindows"
659 "ConfigureWindow" "CirculateWindow" "GetGeometry" "QueryTree"
660 "InternAtom" "GetAtomName" "ChangeProperty" "DeleteProperty"
661 "GetProperty" "ListProperties" "SetSelectionOwner" "GetSelectionOwner"
662 "ConvertSelection" "SendEvent" "GrabPointer" "UngrabPointer"
663 "GrabButton" "UngrabButton" "ChangeActivePointerGrab" "GrabKeyboard"
664 "UngrabKeyboard" "GrabKey" "UngrabKey" "AllowEvents"
665 "GrabServer" "UngrabServer" "QueryPointer" "GetMotionEvents"
666 "TranslateCoords" "WarpPointer" "SetInputFocus" "GetInputFocus"
667 "QueryKeymap" "OpenFont" "CloseFont" "QueryFont"
668 "QueryTextExtents" "ListFonts" "ListFontsWithInfo" "SetFontPath"
669 "GetFontPath" "CreatePixmap" "FreePixmap" "CreateGC"
670 "ChangeGC" "CopyGC" "SetDashes" "SetClipRectangles"
671 "FreeGC" "ClearToBackground" "CopyArea" "CopyPlane"
672 "PolyPoint" "PolyLine" "PolySegment" "PolyRectangle"
673 "PolyArc" "FillPoly" "PolyFillRectangle" "PolyFillArc"
674 "PutImage" "GetImage" "PolyText8" "PolyText16"
675 "ImageText8" "ImageText16" "CreateColormap" "FreeColormap"
676 "CopyColormapAndFree" "InstallColormap" "UninstallColormap" "ListInstalledColormaps"
677 "AllocColor" "AllocNamedColor" "AllocColorCells" "AllocColorPlanes"
678 "FreeColors" "StoreColors" "StoreNamedColor" "QueryColors"
679 "LookupColor" "CreateCursor" "CreateGlyphCursor" "FreeCursor"
680 "RecolorCursor" "QueryBestSize" "QueryExtension" "ListExtensions"
681 "SetKeyboardMapping" "GetKeyboardMapping" "ChangeKeyboardControl" "GetKeyboardControl"
682 "Bell" "ChangePointerControl" "GetPointerControl" "SetScreenSaver"
683 "GetScreenSaver" "ChangeHosts" "ListHosts" "ChangeAccessControl"
684 "ChangeCloseDownMode" "KillClient" "RotateProperties" "ForceScreenSaver"
685 "SetPointerMapping" "GetPointerMapping" "SetModifierMapping" "GetModifierMapping"))

  ViewVC Help
Powered by ViewVC 1.1.5