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

Contents of /src/clx/display.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.16 - (hide 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 ram 1.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 fgilham 1.13
21 dtc 1.7 #+cmu
22 rtoy 1.16 (ext:file-comment "$Id: display.lisp,v 1.16 2010/11/16 19:13:55 rtoy Exp $")
23 ram 1.1
24     (in-package :xlib)
25    
26 fgilham 1.13 ;;; Authorizaton
27    
28     (defparameter *known-authorizations* '("MIT-MAGIC-COOKIE-1"))
29    
30     ;;; X11 Authorization: to prevent malicious users from snooping on a
31 toy 1.9 ;;; 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 fgilham 1.13 ;;; $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 toy 1.9 ;;; The format of the .Xauthority file is documented in the XFree
40     ;;; sources, in the file xc/lib/Xau/README.
41 ram 1.3
42 fgilham 1.13 ;;; 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 ram 1.3
90     (defun get-best-authorization (host display protocol)
91 fgilham 1.13 ;; 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 rtoy 1.16 (or (equal host-address address)
121     (and (eql family :local)
122     (equal address "localhost")))
123 fgilham 1.13 (= 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 ram 1.3
138 rtoy 1.14 (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 ram 1.1 ;;
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 rtoy 1.14 ;; Allocate a resource-id for use in DISPLAY
173 ram 1.1 (declare (type display display))
174 ram 1.3 (declare (clx-values resource-id))
175 rtoy 1.14 (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 ram 1.1
190     (defmacro allocate-resource-id (display object type)
191     ;; Allocate a resource-id for OBJECT in DISPLAY
192 rtoy 1.14 `(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 ram 1.1
199     (defmacro deallocate-resource-id (display id type)
200 rtoy 1.14 (declare (ignore type))
201 ram 1.1 ;; Deallocate a resource-id for OBJECT in DISPLAY
202 rtoy 1.14 `(deallocate-resource-id-internal ,display ,id))
203 ram 1.1
204     (defun deallocate-resource-id-internal (display id)
205 rtoy 1.14 (with-display (display)
206     (remhash id (display-resource-id-map display))))
207 ram 1.1
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 rtoy 1.14 ;; cache the object associated with ID for this display.
214 ram 1.1 (declare (type display display)
215     (type integer id)
216     (type t object))
217 ram 1.3 (declare (clx-values object))
218 rtoy 1.14 ;; 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 ram 1.1
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 ram 1.3 (declare (clx-values ,type))
237 fgilham 1.13 ,(if (member type +clx-cached-types+)
238 ram 1.1 `(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 fgilham 1.13 ,(cond ((null +type-check?+)
245 ram 1.1 `(t ,type))
246     ((member type '(window pixmap))
247     `((type? ,type 'drawable) ,type))
248     (t `((type? ,type ',type) ,type)))
249 fgilham 1.13 ,@(when +type-check?+
250 ram 1.1 `((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 ram 1.3 (declare (clx-values (or null keyword)))
273 ram 1.1 (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 ram 1.3 (declare (clx-values (or null resource-id)))
280 ram 1.2 (gethash (if (or (null atom) (keywordp atom)) atom (kintern atom))
281 ram 1.1 (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 ram 1.3 (declare (clx-values resource-id))
289 ram 1.2 (let ((atom (if (or (null atom) (keywordp atom)) atom (kintern atom))))
290 ram 1.1 (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 fgilham 1.13 (dotimes (i (length +predefined-atoms+))
298 ram 1.1 (declare (type resource-id i))
299 fgilham 1.13 (setf (atom-id (svref +predefined-atoms+ i) display) i)))
300 ram 1.1
301     (defun visual-info (display visual-id)
302     (declare (type display display)
303     (type resource-id visual-id)
304 ram 1.3 (clx-values visual-info))
305 ram 1.1 (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 fgilham 1.13 #+clx-ansi-common-lisp
332 ram 1.1 (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 fgilham 1.13 #+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 ram 1.1 (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 fgilham 1.13 (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 ram 1.1 ;;
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 fgilham 1.13 ;; system dependent. The default protocol is system specific. Authorization,
390     ;; if any, is assumed to come from the environment somehow.
391 ram 1.3 (declare (type integer display))
392     (declare (clx-values display))
393 rtoy 1.15 (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 ram 1.1
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 rtoy 1.14 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 ram 1.1 (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 ram 1.3 (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 ram 1.1 (buffer-force-output display)
455     (let ((reply-buffer nil))
456     (declare (type (or null reply-buffer) reply-buffer))
457     (unwind-protect
458 rtoy 1.14 (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 ram 1.2 (make-colormap :id default-colormap-id :display display))
526 rtoy 1.14 (screen
527 ram 1.1 (make-screen
528 rtoy 1.14 :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 ram 1.1 :id visual
560     :display display
561     :class (member8-get 4 :static-gray :gray-scale
562 rtoy 1.14 :static-color :pseudo-color
563     :true-color :direct-color)
564 ram 1.1 :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 rtoy 1.14 (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 ram 1.1 (when reply-buffer
582     (deallocate-reply-buffer reply-buffer))))
583     display)
584    
585     (defun display-protocol-version (display)
586     (declare (type display display))
587 ram 1.3 (declare (clx-values major minor))
588 ram 1.1 (values (display-protocol-major-version display)
589     (display-protocol-minor-version display)))
590    
591     (defun display-vendor (display)
592     (declare (type display display))
593 ram 1.3 (declare (clx-values name release))
594 ram 1.1 (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 fgilham 1.13 ;; 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 ram 1.1 ;; :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 fgilham 1.13 ;; 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 ram 1.1
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 fgilham 1.13 (with-buffer-request-and-reply (display +x-getinputfocus+ 16 :sizes (8 32))
649 ram 1.1 ()
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