From f12d5a23cb009061dedac4740453f322c278ea06 Mon Sep 17 00:00:00 2001 From: emarsden <emarsden> Date: Fri, 13 Aug 2004 12:24:30 +0000 Subject: [PATCH] Change the way that X11 authorization data is searched for when connecting to localhost. Responsibility for calling GET-BEST-AUTHORIZATION was distributed between EXT:OPEN-CLX-DISPLAY and XLIB:OPEN-DISPLAY; all authorization handling has been moved to XLIB:OPEN-DISPLAY. O-C-D now only deals with parsing $DISPLAY. This rearrangement should fix X11 authorization problems seen with servers that don't listen to TCP connection requests, and thus don't create an MIT-MAGIC-COOKIE for TCP connections. --- clx/display.lisp | 38 +++++++++++++++++++++++--------------- code/clx-ext.lisp | 26 +++++--------------------- 2 files changed, 28 insertions(+), 36 deletions(-) diff --git a/clx/display.lisp b/clx/display.lisp index cd10a5b88..4a2937ee8 100644 --- a/clx/display.lisp +++ b/clx/display.lisp @@ -19,7 +19,7 @@ ;;; #+cmu (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/display.lisp,v 1.11 2003/08/29 09:17:50 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/display.lisp,v 1.12 2004/08/13 12:24:30 emarsden Exp $") (in-package :xlib) @@ -312,29 +312,37 @@ ,@(and timeout `(:timeout ,timeout))) ,@body)))) -(defun open-display (host &key (display 0) protocol authorization-name authorization-data) +(defun open-display (host &key (display 0) (protocol :tcp) 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. + ;; things to circumvent the network 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. + ;; system dependent. The default protocol is system specific. (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 :unix - (let ((actual-protocol (if (member host '("" "unix") :test #'equal) - :unix - protocol))) + ;; If the HOST argument is empty (for instance the $DISPLAY environment variable was + ;; ":0") or if it is the special case of "unix", we connect to the X server using + ;; the :unix protocol. This is the most efficient transport to the local host, most + ;; often a Unix-domain socket. In this case, X11 does not store authorization data + ;; under the name "localhost", since that would make it impossible to store + ;; authorization data for concurrent X11 sessions on different hosts in the same + ;; $XAUTHORITY file. Rather, the authorization data is stored under the local host's + ;; hostname. + (let ((auth-host host)) + (when (or (equal host "") (equal host "unix")) + (setf protocol :unix) + (setf auth-host (machine-instance))) + ;; If no authorization data was specified by the user, attempt to extract + ;; authorization data from the environment. (when (null authorization-name) (multiple-value-setq (authorization-name authorization-data) - (get-best-authorization host display actual-protocol))) - ;; PROTOCOL is the network protocol (something like :TCP or :UNIX). - (let* ((stream (open-x-stream host display actual-protocol)) - (disp (make-buffer *output-buffer-size* #'make-display-internal + (get-best-authorization auth-host display protocol))) + ;; PROTOCOL is the network protocol used to connect to the server + ;; (either :TCP or :UNIX). + (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)) diff --git a/code/clx-ext.lisp b/code/clx-ext.lisp index 9df35bc95..991fcdadd 100644 --- a/code/clx-ext.lisp +++ b/code/clx-ext.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/clx-ext.lisp,v 1.18 2003/08/29 09:17:50 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/clx-ext.lisp,v 1.19 2004/08/13 12:24:30 emarsden Exp $") ;;; ;;; ********************************************************************** ;;; @@ -40,19 +40,16 @@ (defun open-clx-display (&optional (string (cdr (assoc :display *environment-list* :test #'eq)))) - "Parses a display specification including display and screen numbers. - This returns nil when there is no DISPLAY environment variable. If string + "Parses the display specifier STRING, including display and screen numbers. + STRING defaults to the value of the DISPLAY environment variable. If STRING is non-nil, and any fields are missing in the specification, this signals an error. If you specify a screen, then this sets XLIB:DISPLAY-DEFAULT-SCREEN to that screen since CLX initializes this form to the first of - XLIB:SCREEN-ROOTS. This returns the display and screen objects." + XLIB:SCREEN-ROOTS. Return the display and screen objects." (when string (let* ((string (coerce string 'simple-string)) (length (length string)) (host-name "") - (protocol :tcp) - (auth-name nil) - (auth-data nil) (display-num nil) (screen-num nil)) (declare (simple-string string)) @@ -82,20 +79,7 @@ (setf screen-num (parse-integer string :start start :end second-dot))))))))))) - ;; If the $DISPLAY does not specify a hostname (for instance - ;; ":0"), or if the hostname is the special case of "unix", we - ;; connect to the X server using the :unix protocol. This is the - ;; most efficient transport to the local host, most often a Unix - ;; domain socket. In all other cases, we use the :tcp protocol. - (when (or (equal host-name "") (equal host-name "unix")) - (setq protocol :unix) - (multiple-value-setq (auth-name auth-data) - (xlib::get-best-authorization (machine-instance) display-num :tcp))) - (let ((display (xlib:open-display host-name - :display display-num - :protocol protocol - :authorization-name auth-name - :authorization-data auth-data))) + (let ((display (xlib:open-display host-name :display display-num))) (when screen-num (let* ((screens (xlib:display-roots display)) (num-screens (length screens))) -- GitLab