diff --git a/clx.lisp b/clx.lisp index 42a37dc..7875b6b 100644 --- a/clx.lisp +++ b/clx.lisp @@ -504,6 +504,18 @@ :static) #+sbcl #'equalp) +(defparameter *protocol-families* + '(;; X11/X.h, Family* + (:internet . 0) + (:decnet . 1) + (:chaos . 2) + ;; X11/Xauth.h "not part of X standard" + (:Local . 256) + (:Wild . 65535) + (:Netname . 254) + (:Krb5Principal . 253) + (:LocalHost . 252))) + (deftype win-gravity () '(member :unmap :north-west :north :north-east :west :center :east :south-west :south :south-east :static)) diff --git a/dependent.lisp b/dependent.lisp index 78764f8..dd4568f 100644 --- a/dependent.lisp +++ b/dependent.lisp @@ -2546,7 +2546,7 @@ (let ((hostent (get-host-by-name (string host)))) (ecase family ((:internet nil 0) - (cons :internet (coerce (host-ent-address hostent) 'list))))))) + (cons :internet (coerce (host-ent-address hostent) 'list)))))) #+explorer ;; This isn't required, but it helps make sense of the results from access-hosts (defun get-host (host-object) @@ -2643,6 +2643,15 @@ #+sbcl (sb-ext:posix-getenv name) #-(or sbcl excl lcl3.0 CMU) (progn name nil)) +(defun get-host-name () + "Return the same hostname as gethostname(3) would" + ;; machine-instance probably works on a lot of lisps, but clisp is not + ;; one of them + #+(or cmu sbcl) (machine-instance) + ;; resources-pathname was using short-site-name for this purpose + #+excl (short-site-name) + #-(or excl cmu sbcl) (error "get-host-name not implemented")) + (defun homedir-file-pathname (name) (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal) (merge-pathnames (user-homedir-pathname) (pathname name)))) @@ -2660,9 +2669,8 @@ (or (let ((string (getenv "XENVIRONMENT"))) (and string (pathname string))) - (homedir-file-pathname (concatenate 'string ".Xdefaults-" - #+excl (short-site-name) - #-excl (machine-instance))))) + (homedir-file-pathname + (concatenate 'string ".Xdefaults-" (get-host-name))))) ;;; AUTHORITY-PATHNAME - The pathname of the authority file. @@ -2677,7 +2685,7 @@ (defun get-default-display () "Get the default X display as list of (host display-number screen protocol). In UNIX this is selected using the DISPLAY environment variable, and -may use :internet or :unix protocol" +may use :internet or :local protocol" (let* ((name (or (getenv "DISPLAY") (error "DISPLAY environment variable is not set"))) (colon-i (position #\: name)) @@ -2689,7 +2697,7 @@ may use :internet or :unix protocol" (screen (if dot-i (ignore-errors (parse-integer name :start (1+ dot-i))))) (protocol (if (or (string= host "") (string-equal host "unix")) - :unix + :local :internet))) (list host (or display 0) (or screen 0) protocol))) diff --git a/display.lisp b/display.lisp index 4042f94..75d6094 100644 --- a/display.lisp +++ b/display.lisp @@ -62,18 +62,20 @@ (let* ((address (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))) + (data (read-short-length-vector stream)) + (family (or (car (rassoc family *protocol-families*)) family))) (list - (case family - (0 :internet) (1 :dna) (2 :chaos) (256 :unix) (t :unknown)) - (if (eq family 256) (map 'string #'code-char address) address) + family + (ecase family + (:local (map 'string #'code-char address)) + (:internet (coerce address 'list))) 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 (values of :tcp or :internet) or a non-network - ;; protocol such as Unix domain sockets (value of :unix). Returns + ;; 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, @@ -83,17 +85,23 @@ (with-open-file (stream pathname :element-type '(unsigned-byte 8) :if-does-not-exist nil) (when stream - (let* ((host-address (unless (eql protocol :unix) - (rest (host-address host protocol)))) + (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) - (or (eql protocol :unix) - (equal host-address (coerce address 'list))) + (equal host-address address) (= number display) (let ((pos1 (position name *known-authorizations* :test #'string=))) @@ -314,6 +322,11 @@ ,@(and timeout `(:timeout ,timeout))) ,@body)))) +(defun open-default-display () + (destructuring-bind (host display screen protocol) (get-default-display) + (declare (ignore screen)) + (open-display host :display display :protocol protocol))) + (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 @@ -328,13 +341,13 @@ (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 :unix + ;; 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) - :unix + :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))