mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-16 22:32:05 -08:00
680 lines
28 KiB
Common Lisp
680 lines
28 KiB
Common Lisp
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
|
||
|
||
;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11
|
||
|
||
;;;
|
||
;;; TEXAS INSTRUMENTS INCORPORATED
|
||
;;; P.O. BOX 2909
|
||
;;; AUSTIN, TEXAS 78769
|
||
;;;
|
||
;;; Copyright (C) 1987 Texas Instruments Incorporated.
|
||
;;;
|
||
;;; Permission is granted to any individual or institution to use, copy, modify,
|
||
;;; and distribute this software, provided that this complete copyright and
|
||
;;; permission notice is maintained, intact, in all copies and supporting
|
||
;;; documentation.
|
||
;;;
|
||
;;; Texas Instruments Incorporated provides this software "as is" without
|
||
;;; express or implied warranty.
|
||
;;;
|
||
|
||
(in-package :xlib)
|
||
|
||
;;; Authorizaton
|
||
|
||
(defparameter *known-authorizations* '("MIT-MAGIC-COOKIE-1"))
|
||
|
||
;;; X11 Authorization: to prevent malicious users from snooping on a
|
||
;;; display, X servers may require connection requests to be
|
||
;;; authorized. The X server (or display manager) will create a random
|
||
;;; key on startup, and store it as an entry in a file generally named
|
||
;;; $HOME/.Xauthority (see xauth(1) and the AUTHORITY-PATHNAME
|
||
;;; function). Clients must extract from this file the "magic cookie"
|
||
;;; that corresponds to the server they wish to connect to, and send
|
||
;;; it as authorization data when opening the display.
|
||
|
||
;;; The format of the .Xauthority file is documented in the XFree
|
||
;;; sources, in the file xc/lib/Xau/README.
|
||
|
||
;;; Stolen from the cmucl sources, with patches by Hannu Rummukainen and
|
||
;;; Scott Fahlman.
|
||
|
||
(defun read-xauth-entry (stream)
|
||
(labels ((read-short (stream &optional (eof-errorp t))
|
||
(let ((high-byte (read-byte stream eof-errorp)))
|
||
(and high-byte
|
||
(dpb high-byte (byte 8 8) (read-byte stream)))))
|
||
(read-short-length-string (stream)
|
||
(let ((length (read-short stream)))
|
||
(let ((string (make-string length)))
|
||
(dotimes (k length)
|
||
(setf (schar string k) (card8->char (read-byte stream))))
|
||
string)))
|
||
(read-short-length-vector (stream)
|
||
(let ((length (read-short stream)))
|
||
(let ((vector (make-array length
|
||
:element-type '(unsigned-byte 8))))
|
||
(dotimes (k length)
|
||
(setf (aref vector k) (read-byte stream)))
|
||
vector))))
|
||
(let ((family-id (read-short stream nil)))
|
||
(if (null family-id)
|
||
(list nil nil nil nil nil)
|
||
(let* ((address-data (read-short-length-vector stream))
|
||
(number (parse-integer (read-short-length-string stream)))
|
||
(name (read-short-length-string stream))
|
||
(data (read-short-length-vector stream))
|
||
(family (car (rassoc family-id *protocol-families*))))
|
||
(unless family
|
||
(return-from read-xauth-entry
|
||
;; we return FAMILY-ID to signal to
|
||
;; GET-BEST-AUTHORIZATION that we haven't finished
|
||
;; with the stream.
|
||
(list family-id nil nil nil nil)))
|
||
(let ((address
|
||
(case family
|
||
(:local (map 'string #'code-char address-data))
|
||
(:internet (coerce address-data 'list))
|
||
;; FIXME: we can probably afford not to support
|
||
;; :DECNET or :CHAOSNET in this modern age, but
|
||
;; :INTERNET6 probably deserve support. -- CSR,
|
||
;; 2005-08-07
|
||
(t nil))))
|
||
;; if ADDRESS is NIL by this time, we will never match
|
||
;; the address of DISPLAY.
|
||
(list family address number name data)))))))
|
||
|
||
(defun get-best-authorization (host display protocol)
|
||
;; parse .Xauthority, extract the cookie for DISPLAY on HOST.
|
||
;; PROTOCOL determines whether the server connection is using an
|
||
;; Internet protocol (value of :internet) or a non-network
|
||
;; protocol such as Unix domain sockets (value of :local). Returns
|
||
;; two strings: an authorization name (very likely the string
|
||
;; "MIT-MAGIC-COOKIE-1") and an authorization key, represented as
|
||
;; fixnums in a vector. If we fail to find an appropriate cookie,
|
||
;; return two empty strings.
|
||
(let ((pathname (authority-pathname)))
|
||
(when pathname
|
||
(with-open-file (stream pathname :element-type '(unsigned-byte 8)
|
||
:if-does-not-exist nil)
|
||
(when stream
|
||
(let* ((host-address (and (eql protocol :internet)
|
||
(rest (host-address host protocol))))
|
||
(best-name nil) (best-pos nil)
|
||
(best-data nil))
|
||
;; Check for the localhost address, in which case we're
|
||
;; really FamilyLocal.
|
||
(when (or (eql protocol :local)
|
||
(and (eql protocol :internet)
|
||
(equal host-address '(127 0 0 1))))
|
||
(setq host-address (get-host-name))
|
||
(setq protocol :local))
|
||
(loop
|
||
(destructuring-bind (family address number name data)
|
||
(read-xauth-entry stream)
|
||
(unless family (return))
|
||
(when (and (eql family protocol)
|
||
(equal host-address address)
|
||
(= number display)
|
||
(let ((pos1 (position name *known-authorizations*
|
||
:test #'string=)))
|
||
(and pos1
|
||
(or (null best-pos)
|
||
(< pos1 best-pos)))))
|
||
(setf best-name name
|
||
best-pos (position name *known-authorizations*
|
||
:test #'string=)
|
||
best-data data))))
|
||
(when best-name
|
||
(return-from get-best-authorization
|
||
(values best-name best-data)))))))
|
||
(values "" "")))
|
||
|
||
(defmacro with-display ((display &key timeout inline)
|
||
&body body)
|
||
;; This macro is for use in a multi-process environment. It
|
||
;; provides exclusive access to the local display object for
|
||
;; multiple request generation. It need not provide immediate
|
||
;; exclusive access for replies; that is, if another process is
|
||
;; waiting for a reply (while not in a with-display), then
|
||
;; synchronization need not (but can) occur immediately. Except
|
||
;; where noted, all routines effectively contain an implicit
|
||
;; with-display where needed, so that correct synchronization is
|
||
;; always provided at the interface level on a per-call basis.
|
||
;; Nested uses of this macro will work correctly. This macro does
|
||
;; not prevent concurrent event processing; see with-event-queue.
|
||
`(with-buffer (,display
|
||
,@(and timeout `(:timeout ,timeout))
|
||
,@(and inline `(:inline ,inline)))
|
||
,@body))
|
||
|
||
;;
|
||
;; Resource id management
|
||
;;
|
||
(defun initialize-resource-allocator (display)
|
||
;; Find the resource-id-byte (appropriate for LDB & DPB) from the resource-id-mask
|
||
(let ((id-mask (display-resource-id-mask display)))
|
||
(unless (zerop id-mask) ;; zero mask is an error
|
||
(do ((first 0 (index1+ first))
|
||
(mask id-mask (the mask32 (ash mask -1))))
|
||
((oddp mask)
|
||
(setf (display-resource-id-byte display)
|
||
(byte (integer-length mask) first)))
|
||
(declare (type array-index first)
|
||
(type mask32 mask))))))
|
||
|
||
(defun resourcealloc (display)
|
||
;; Allocate a resource-id for use in DISPLAY
|
||
(declare (type display display))
|
||
(declare (clx-values resource-id))
|
||
(loop for next-count upfrom (1+ (display-resource-id-count display))
|
||
repeat (1+ (display-resource-id-mask display))
|
||
as id = (dpb next-count
|
||
(display-resource-id-byte display)
|
||
(display-resource-id-base display))
|
||
unless (nth-value 1 (gethash id (display-resource-id-map display)))
|
||
do (setf (display-resource-id-count display) next-count)
|
||
(setf (gethash id (display-resource-id-map display)) t)
|
||
(return-from resourcealloc id))
|
||
;; internal consistency check
|
||
(assert (= (hash-table-count (display-resource-id-map display))
|
||
(1+ (display-resource-id-mask display))))
|
||
;; tell the user what's gone wrong
|
||
(error 'resource-ids-exhausted))
|
||
|
||
(defmacro allocate-resource-id (display object type)
|
||
;; Allocate a resource-id for OBJECT in DISPLAY
|
||
`(with-display (,display)
|
||
,(if (member (eval type) +clx-cached-types+)
|
||
`(let ((id (funcall (display-xid ,display) ,display)))
|
||
(save-id ,display id ,object)
|
||
id)
|
||
`(funcall (display-xid ,display) ,display))))
|
||
|
||
(defmacro deallocate-resource-id (display id type)
|
||
(declare (ignore type))
|
||
;; Deallocate a resource-id for OBJECT in DISPLAY
|
||
`(deallocate-resource-id-internal ,display ,id))
|
||
|
||
(defun deallocate-resource-id-internal (display id)
|
||
(with-display (display)
|
||
(remhash id (display-resource-id-map display))))
|
||
|
||
(defun lookup-resource-id (display id)
|
||
;; Find the object associated with resource ID
|
||
(gethash id (display-resource-id-map display)))
|
||
|
||
(defun save-id (display id object)
|
||
;; cache the object associated with ID for this display.
|
||
(declare (type display display)
|
||
(type integer id)
|
||
(type t object))
|
||
(declare (clx-values object))
|
||
;; we can't cache objects from other clients, because they may
|
||
;; become invalid without us being told about that.
|
||
(let ((base (display-resource-id-base display))
|
||
(mask (display-resource-id-mask display)))
|
||
(when (= (logandc2 id mask) base)
|
||
(setf (gethash id (display-resource-id-map display)) object))
|
||
object))
|
||
|
||
;; Define functions to find the CLX data types given a display and resource-id
|
||
;; If the data type is being cached, look there first.
|
||
(macrolet ((generate-lookup-functions (useless-name &body types)
|
||
`(within-definition (,useless-name generate-lookup-functions)
|
||
,@(mapcar
|
||
#'(lambda (type)
|
||
`(defun ,(xintern 'lookup- type)
|
||
(display id)
|
||
(declare (type display display)
|
||
(type resource-id id))
|
||
(declare (clx-values ,type))
|
||
,(if (member type +clx-cached-types+)
|
||
`(let ((,type (lookup-resource-id display id)))
|
||
(cond ((null ,type) ;; Not found, create and save it.
|
||
(setq ,type (,(xintern 'make- type)
|
||
:display display :id id))
|
||
(save-id display id ,type))
|
||
;; Found. Check the type
|
||
,(cond ((null +type-check?+)
|
||
`(t ,type))
|
||
((member type '(window pixmap))
|
||
`((type? ,type 'drawable) ,type))
|
||
(t `((type? ,type ',type) ,type)))
|
||
,@(when +type-check?+
|
||
`((t (x-error 'lookup-error
|
||
:id id
|
||
:display display
|
||
:type ',type
|
||
:object ,type))))))
|
||
;; Not being cached. Create a new one each time.
|
||
`(,(xintern 'make- type)
|
||
:display display :id id))))
|
||
types))))
|
||
(generate-lookup-functions ignore
|
||
drawable
|
||
window
|
||
pixmap
|
||
gcontext
|
||
cursor
|
||
colormap
|
||
font))
|
||
|
||
(defun id-atom (id display)
|
||
;; Return the cached atom for an atom ID
|
||
(declare (type resource-id id)
|
||
(type display display))
|
||
(declare (clx-values (or null keyword)))
|
||
(gethash id (display-atom-id-map display)))
|
||
|
||
(defun atom-id (atom display)
|
||
;; Return the ID for an atom in DISPLAY
|
||
(declare (type xatom atom)
|
||
(type display display))
|
||
(declare (clx-values (or null resource-id)))
|
||
(gethash (if (or (null atom) (keywordp atom)) atom (kintern atom))
|
||
(display-atom-cache display)))
|
||
|
||
(defun set-atom-id (atom display id)
|
||
;; Set the ID for an atom in DISPLAY
|
||
(declare (type xatom atom)
|
||
(type display display)
|
||
(type resource-id id))
|
||
(declare (clx-values resource-id))
|
||
(let ((atom (if (or (null atom) (keywordp atom)) atom (kintern atom))))
|
||
(setf (gethash id (display-atom-id-map display)) atom)
|
||
(setf (gethash atom (display-atom-cache display)) id)
|
||
id))
|
||
|
||
(defsetf atom-id set-atom-id)
|
||
|
||
(defun initialize-predefined-atoms (display)
|
||
(dotimes (i (length +predefined-atoms+))
|
||
(declare (type resource-id i))
|
||
(setf (atom-id (svref +predefined-atoms+ i) display) i)))
|
||
|
||
(defun visual-info (display visual-id)
|
||
(declare (type display display)
|
||
(type resource-id visual-id)
|
||
(clx-values visual-info))
|
||
(when (zerop visual-id)
|
||
(return-from visual-info nil))
|
||
(dolist (screen (display-roots display))
|
||
(declare (type screen screen))
|
||
(dolist (depth (screen-depths screen))
|
||
(declare (type cons depth))
|
||
(dolist (visual-info (rest depth))
|
||
(declare (type visual-info visual-info))
|
||
(when (funcall (resource-id-map-test) visual-id (visual-info-id visual-info))
|
||
(return-from visual-info visual-info)))))
|
||
(error "Visual info not found for id #x~x in display ~s." visual-id display))
|
||
|
||
|
||
;;
|
||
;; Display functions
|
||
;;
|
||
(defmacro with-event-queue ((display &key timeout inline)
|
||
&body body &environment env)
|
||
;; exclusive access to event queue
|
||
`(macrolet ((with-event-queue ((display &key timeout) &body body)
|
||
;; Speedup hack for lexically nested with-event-queues
|
||
`(progn
|
||
(progn ,display ,@(and timeout `(,timeout)) nil)
|
||
,@body)))
|
||
,(if (and (null inline) (macroexpand '(use-closures) env))
|
||
`(flet ((.with-event-queue-body. () ,@body))
|
||
#+clx-ansi-common-lisp
|
||
(declare (dynamic-extent #'.with-event-queue-body.))
|
||
(with-event-queue-function
|
||
,display ,timeout #'.with-event-queue-body.))
|
||
(let ((disp (if (or (symbolp display) (constantp display))
|
||
display
|
||
'.display.)))
|
||
`(let (,@(unless (eq disp display) `((,disp ,display))))
|
||
(holding-lock ((display-event-lock ,disp) ,disp "CLX Event Lock"
|
||
,@(and timeout `(:timeout ,timeout)))
|
||
,@body))))))
|
||
|
||
(defun with-event-queue-function (display timeout function)
|
||
(declare (type display display)
|
||
(type (or null number) timeout)
|
||
(type function function)
|
||
#+clx-ansi-common-lisp
|
||
(dynamic-extent function)
|
||
;; FIXME: see SBCL bug #243
|
||
(ignorable display timeout)
|
||
#+(and lispm (not clx-ansi-common-lisp))
|
||
(sys:downward-funarg function))
|
||
(with-event-queue (display :timeout timeout :inline t)
|
||
(funcall function)))
|
||
|
||
(defmacro with-event-queue-internal ((display &key timeout) &body body)
|
||
;; exclusive access to the internal event queues
|
||
(let ((disp (if (or (symbolp display) (constantp display)) display '.display.)))
|
||
`(let (,@(unless (eq disp display) `((,disp ,display))))
|
||
(holding-lock ((display-event-queue-lock ,disp) ,disp "CLX Event Queue Lock"
|
||
,@(and timeout `(:timeout ,timeout)))
|
||
,@body))))
|
||
|
||
(defun open-default-display (&optional display-name)
|
||
"Open a connection to DISPLAY-NAME if supplied, or to the appropriate
|
||
default display as given by GET-DEFAULT-DISPLAY otherwise.
|
||
|
||
OPEN-DISPLAY-NAME always attempts to do display authorization. The
|
||
hostname is resolved to an address, then authorization data for the
|
||
(protocol, host-address, displaynumber) triple is looked up in the
|
||
file given by AUTHORITY_PATHNAME (typically $HOME/.Xauthority). If
|
||
the protocol is :local, or if the hostname resolves to the local host,
|
||
authority data for the local machine's actual hostname - as returned by
|
||
gethostname(3) - is used instead."
|
||
(destructuring-bind (host display screen protocol)
|
||
(get-default-display display-name)
|
||
(let ((display (open-display host :display display :protocol protocol)))
|
||
(setf (display-default-screen display) (nth screen (display-roots display)))
|
||
display)))
|
||
|
||
(defun open-display (host &key (display 0) protocol authorization-name authorization-data)
|
||
;; Implementation specific routine to setup the buffer for a
|
||
;; specific host and display. This must interface with the local
|
||
;; network facilities, and will probably do special things to
|
||
;; circumvent the nework when displaying on the local host.
|
||
;;
|
||
;; A string must be acceptable as a host, but otherwise the possible types
|
||
;; for host and protocol are not constrained, and will likely be very
|
||
;; system dependent. The default protocol is system specific. Authorization,
|
||
;; if any, is assumed to come from the environment somehow.
|
||
(declare (type integer display))
|
||
(declare (clx-values display))
|
||
;; Get the authorization mechanism from the environment. Handle the
|
||
;; special case of a host name of "" and "unix" which means the
|
||
;; protocol is :local
|
||
(when (null authorization-name)
|
||
(multiple-value-setq (authorization-name authorization-data)
|
||
(get-best-authorization host
|
||
display
|
||
(if (member host '("" "unix") :test #'equal)
|
||
:local
|
||
protocol))))
|
||
;; PROTOCOL is the network protocol (something like :TCP :DNA or :CHAOS). See OPEN-X-STREAM.
|
||
(let* ((stream (open-x-stream host display protocol))
|
||
(disp (make-buffer *output-buffer-size* #'make-display-internal
|
||
:host host :display display
|
||
:output-stream stream :input-stream stream))
|
||
(ok-p nil))
|
||
(unwind-protect
|
||
(progn
|
||
(display-connect disp
|
||
:authorization-name authorization-name
|
||
:authorization-data authorization-data)
|
||
(setf (display-authorization-name disp) authorization-name)
|
||
(setf (display-authorization-data disp) authorization-data)
|
||
(initialize-resource-allocator disp)
|
||
(initialize-predefined-atoms disp)
|
||
(initialize-extensions disp)
|
||
(when (assoc "BIG-REQUESTS" (display-extension-alist disp)
|
||
:test #'string=)
|
||
(enable-big-requests disp))
|
||
(setq ok-p t))
|
||
(unless ok-p (close-display disp :abort t)))
|
||
disp))
|
||
|
||
(defun display-force-output (display)
|
||
; Output is normally buffered, this forces any buffered output to the server.
|
||
(declare (type display display))
|
||
(with-display (display)
|
||
(buffer-force-output display)))
|
||
|
||
(defun close-display (display &key abort)
|
||
;; Close the host connection in DISPLAY
|
||
(declare (type display display))
|
||
(close-buffer display :abort abort))
|
||
|
||
(defun display-connect (display &key authorization-name authorization-data)
|
||
(with-buffer-output (display :sizes (8 16))
|
||
(card8-put
|
||
0
|
||
(ecase (display-byte-order display)
|
||
(:lsbfirst #x6c) ;; Ascii lowercase l - Least Significant Byte First
|
||
(:msbfirst #x42))) ;; Ascii uppercase B - Most Significant Byte First
|
||
(card16-put 2 *protocol-major-version*)
|
||
(card16-put 4 *protocol-minor-version*)
|
||
(card16-put 6 (length authorization-name))
|
||
(card16-put 8 (length authorization-data))
|
||
(write-sequence-char display 12 authorization-name)
|
||
(if (stringp authorization-data)
|
||
(write-sequence-char display (lround (+ 12 (length authorization-name)))
|
||
authorization-data)
|
||
(write-sequence-card8 display (lround (+ 12 (length authorization-name)))
|
||
authorization-data)))
|
||
(buffer-force-output display)
|
||
(let ((reply-buffer nil))
|
||
(declare (type (or null reply-buffer) reply-buffer))
|
||
(unwind-protect
|
||
(progn
|
||
(setq reply-buffer (allocate-reply-buffer #x1000))
|
||
(with-buffer-input (reply-buffer :sizes (8 16 32))
|
||
(buffer-input display buffer-bbuf 0 8)
|
||
(let ((success (boolean-get 0))
|
||
(reason-length (card8-get 1))
|
||
(major-version (card16-get 2))
|
||
(minor-version (card16-get 4))
|
||
(total-length (card16-get 6))
|
||
vendor-length
|
||
num-roots
|
||
num-formats)
|
||
(declare (ignore total-length))
|
||
(unless success
|
||
(x-error 'connection-failure
|
||
:major-version major-version
|
||
:minor-version minor-version
|
||
:host (display-host display)
|
||
:display (display-display display)
|
||
:reason
|
||
(progn (buffer-input display buffer-bbuf 0 reason-length)
|
||
(string-get reason-length 0 :reply-buffer reply-buffer))))
|
||
(buffer-input display buffer-bbuf 0 32)
|
||
(setf (display-protocol-major-version display) major-version)
|
||
(setf (display-protocol-minor-version display) minor-version)
|
||
(setf (display-release-number display) (card32-get 0))
|
||
(setf (display-resource-id-base display) (card32-get 4))
|
||
(setf (display-resource-id-mask display) (card32-get 8))
|
||
(setf (display-motion-buffer-size display) (card32-get 12))
|
||
(setq vendor-length (card16-get 16))
|
||
(setf (display-max-request-length display) (card16-get 18))
|
||
(setq num-roots (card8-get 20))
|
||
(setq num-formats (card8-get 21))
|
||
;; Get the image-info
|
||
(setf (display-image-lsb-first-p display) (zerop (card8-get 22)))
|
||
(let ((format (display-bitmap-format display)))
|
||
(declare (type bitmap-format format))
|
||
(setf (bitmap-format-lsb-first-p format) (zerop (card8-get 23)))
|
||
(setf (bitmap-format-unit format) (card8-get 24))
|
||
(setf (bitmap-format-pad format) (card8-get 25)))
|
||
(setf (display-min-keycode display) (card8-get 26))
|
||
(setf (display-max-keycode display) (card8-get 27))
|
||
;; 4 bytes unused
|
||
;; Get the vendor string
|
||
(buffer-input display buffer-bbuf 0 (lround vendor-length))
|
||
(setf (display-vendor-name display)
|
||
(string-get vendor-length 0 :reply-buffer reply-buffer))
|
||
;; Initialize the pixmap formats
|
||
(dotimes (i num-formats) ;; loop gathering pixmap formats
|
||
(declare (ignorable i))
|
||
(buffer-input display buffer-bbuf 0 8)
|
||
(push (make-pixmap-format :depth (card8-get 0)
|
||
:bits-per-pixel (card8-get 1)
|
||
:scanline-pad (card8-get 2))
|
||
; 5 unused bytes
|
||
(display-pixmap-formats display)))
|
||
(setf (display-pixmap-formats display)
|
||
(nreverse (display-pixmap-formats display)))
|
||
;; Initialize the screens
|
||
(dotimes (i num-roots)
|
||
(declare (ignorable i))
|
||
(buffer-input display buffer-bbuf 0 40)
|
||
(let* ((root-id (card32-get 0))
|
||
(root (make-window :id root-id :display display))
|
||
(root-visual (card32-get 32))
|
||
(default-colormap-id (card32-get 4))
|
||
(default-colormap
|
||
(make-colormap :id default-colormap-id :display display))
|
||
(screen
|
||
(make-screen
|
||
:root root
|
||
:default-colormap default-colormap
|
||
:white-pixel (card32-get 8)
|
||
:black-pixel (card32-get 12)
|
||
:event-mask-at-open (card32-get 16)
|
||
:width (card16-get 20)
|
||
:height (card16-get 22)
|
||
:width-in-millimeters (card16-get 24)
|
||
:height-in-millimeters (card16-get 26)
|
||
:min-installed-maps (card16-get 28)
|
||
:max-installed-maps (card16-get 30)
|
||
:backing-stores (member8-get 36 :never :when-mapped :always)
|
||
:save-unders-p (boolean-get 37)
|
||
:root-depth (card8-get 38)))
|
||
(num-depths (card8-get 39))
|
||
(depths nil))
|
||
;; Save root window for event reporting
|
||
(save-id display root-id root)
|
||
(save-id display default-colormap-id default-colormap)
|
||
;; Create the depth AList for a screen, (depth . visual-infos)
|
||
(dotimes (j num-depths)
|
||
(declare (ignorable j))
|
||
(buffer-input display buffer-bbuf 0 8)
|
||
(let ((depth (card8-get 0))
|
||
(num-visuals (card16-get 2))
|
||
(visuals nil)) ;; 4 bytes unused
|
||
(dotimes (k num-visuals)
|
||
(declare (ignorable k))
|
||
(buffer-input display buffer-bbuf 0 24)
|
||
(let* ((visual (card32-get 0))
|
||
(visual-info (make-visual-info
|
||
:id visual
|
||
:display display
|
||
:class (member8-get 4 :static-gray :gray-scale
|
||
:static-color :pseudo-color
|
||
:true-color :direct-color)
|
||
:bits-per-rgb (card8-get 5)
|
||
:colormap-entries (card16-get 6)
|
||
:red-mask (card32-get 8)
|
||
:green-mask (card32-get 12)
|
||
:blue-mask (card32-get 16)
|
||
;; 4 bytes unused
|
||
)))
|
||
(push visual-info visuals)
|
||
(when (funcall (resource-id-map-test) root-visual visual)
|
||
(setf (screen-root-visual-info screen)
|
||
(setf (colormap-visual-info default-colormap)
|
||
visual-info)))))
|
||
(push (cons depth (nreverse visuals)) depths)))
|
||
(setf (screen-depths screen) (nreverse depths))
|
||
(push screen (display-roots display))))
|
||
(setf (display-roots display) (nreverse (display-roots display)))
|
||
(setf (display-default-screen display) (first (display-roots display))))))
|
||
(when reply-buffer
|
||
(deallocate-reply-buffer reply-buffer))))
|
||
display)
|
||
|
||
(defun display-protocol-version (display)
|
||
(declare (type display display))
|
||
(declare (clx-values major minor))
|
||
(values (display-protocol-major-version display)
|
||
(display-protocol-minor-version display)))
|
||
|
||
(defun display-vendor (display)
|
||
(declare (type display display))
|
||
(declare (clx-values name release))
|
||
(values (display-vendor-name display)
|
||
(display-release-number display)))
|
||
|
||
(defun display-nscreens (display)
|
||
(declare (type display display))
|
||
(length (display-roots display)))
|
||
|
||
#+comment ;; defined by the DISPLAY defstruct
|
||
(defsetf display-error-handler (display) (handler)
|
||
;; All errors (synchronous and asynchronous) are processed by
|
||
;; calling an error handler in the display. If handler is a
|
||
;; sequence it is expected to contain handler functions specific to
|
||
;; each error; the error code is used to index the sequence,
|
||
;; fetching the appropriate handler. Any results returned by the
|
||
;; handler are ignored; it is assumed the handler either takes care
|
||
;; of the error completely, or else signals. For all core errors,
|
||
;; the keyword/value argument pairs are:
|
||
;; :display display
|
||
;; :error-key error-key
|
||
;; :major integer
|
||
;; :minor integer
|
||
;; :sequence integer
|
||
;; :current-sequence integer
|
||
;; For :colormap, :cursor, :drawable, :font, :gcontext, :id-choice, :pixmap, and
|
||
;; :window errors another pair is:
|
||
;; :resource-id integer
|
||
;; For :atom errors, another pair is:
|
||
;; :atom-id integer
|
||
;; For :value errors, another pair is:
|
||
;; :value integer
|
||
)
|
||
|
||
;; setf'able
|
||
;; If defined, called after every protocol request is generated,
|
||
;; even those inside explicit with-display's, but never called from
|
||
;; inside the after-function itself. The function is called inside
|
||
;; the effective with-display for the associated request. Default
|
||
;; value is nil. Can be set, for example, to #'display-force-output
|
||
;; or #'display-finish-output.
|
||
|
||
(defvar *inside-display-after-function* nil)
|
||
|
||
(defun display-invoke-after-function (display)
|
||
; Called after every protocal request is generated
|
||
(declare (type display display))
|
||
(when (and (display-after-function display)
|
||
(not *inside-display-after-function*))
|
||
(let ((*inside-display-after-function* t)) ;; Ensure no recursive calls
|
||
(funcall (display-after-function display) display))))
|
||
|
||
(defun display-finish-output (display)
|
||
;; Forces output, then causes a round-trip to ensure that all possible
|
||
;; errors and events have been received.
|
||
(declare (type display display))
|
||
(with-buffer-request-and-reply (display +x-getinputfocus+ 16 :sizes (8 32))
|
||
()
|
||
)
|
||
;; Report asynchronous errors here if the user wants us to.
|
||
(report-asynchronous-errors display :after-finish-output))
|
||
|
||
(defparameter
|
||
*request-names*
|
||
'#("error" "CreateWindow" "ChangeWindowAttributes" "GetWindowAttributes"
|
||
"DestroyWindow" "DestroySubwindows" "ChangeSaveSet" "ReparentWindow"
|
||
"MapWindow" "MapSubwindows" "UnmapWindow" "UnmapSubwindows"
|
||
"ConfigureWindow" "CirculateWindow" "GetGeometry" "QueryTree"
|
||
"InternAtom" "GetAtomName" "ChangeProperty" "DeleteProperty"
|
||
"GetProperty" "ListProperties" "SetSelectionOwner" "GetSelectionOwner"
|
||
"ConvertSelection" "SendEvent" "GrabPointer" "UngrabPointer"
|
||
"GrabButton" "UngrabButton" "ChangeActivePointerGrab" "GrabKeyboard"
|
||
"UngrabKeyboard" "GrabKey" "UngrabKey" "AllowEvents"
|
||
"GrabServer" "UngrabServer" "QueryPointer" "GetMotionEvents"
|
||
"TranslateCoords" "WarpPointer" "SetInputFocus" "GetInputFocus"
|
||
"QueryKeymap" "OpenFont" "CloseFont" "QueryFont"
|
||
"QueryTextExtents" "ListFonts" "ListFontsWithInfo" "SetFontPath"
|
||
"GetFontPath" "CreatePixmap" "FreePixmap" "CreateGC"
|
||
"ChangeGC" "CopyGC" "SetDashes" "SetClipRectangles"
|
||
"FreeGC" "ClearToBackground" "CopyArea" "CopyPlane"
|
||
"PolyPoint" "PolyLine" "PolySegment" "PolyRectangle"
|
||
"PolyArc" "FillPoly" "PolyFillRectangle" "PolyFillArc"
|
||
"PutImage" "GetImage" "PolyText8" "PolyText16"
|
||
"ImageText8" "ImageText16" "CreateColormap" "FreeColormap"
|
||
"CopyColormapAndFree" "InstallColormap" "UninstallColormap" "ListInstalledColormaps"
|
||
"AllocColor" "AllocNamedColor" "AllocColorCells" "AllocColorPlanes"
|
||
"FreeColors" "StoreColors" "StoreNamedColor" "QueryColors"
|
||
"LookupColor" "CreateCursor" "CreateGlyphCursor" "FreeCursor"
|
||
"RecolorCursor" "QueryBestSize" "QueryExtension" "ListExtensions"
|
||
"SetKeyboardMapping" "GetKeyboardMapping" "ChangeKeyboardControl" "GetKeyboardControl"
|
||
"Bell" "ChangePointerControl" "GetPointerControl" "SetScreenSaver"
|
||
"GetScreenSaver" "ChangeHosts" "ListHosts" "ChangeAccessControl"
|
||
"ChangeCloseDownMode" "KillClient" "RotateProperties" "ForceScreenSaver"
|
||
"SetPointerMapping" "GetPointerMapping" "SetModifierMapping" "GetModifierMapping"))
|