Allows the use of CLX clients over an ssh-forwarded connection.

Allows the use of CLX clients over an ssh-forwarded connection.
Thanks to Eric Marsden for explaining this one and writing the code
in CMUCL CLX that fixes it.

The X authority database is a small file typically found in
$HOME/.Xauthority, each of the records in which is a binary-encoded
tuple of

  (protocol address display-num auth-scheme-name auth-data)

protocol is typically FamilyInternet or FamilyDECnet or something. The
interpretation of address is protocol-specific, the display is a
number, and the auth-data depends on the auth-scheme-name.  With that
said, I don't know of any any authorization schemes other than
MIT-MAGIC-COOKIE-1, for which the auth data is 16 bytes of binary guck.

For FamilyInternet, the address is just the IP address.  That's easy.
However, the authority database may be shared between multiple
machines (for example, if you have NFS-mounted $HOME), so it has to do
something special with local transports (unix sockets, shm, etc) so
that they don't all overwrite each other.  xauth invents some more
Family* constants: the important one here is FamilyLocal, for which
the address is the machine hostname as returned by gethostname().  If
your DISPLAY is set to ":n" or "unix:n", this conventionally indicates
a local connection, so these go into xauthority as FamilyLocal, wich
the machine hostname to disambiguate them.

Many people use SSH X connection forwarding to securely open remote X
displays.  If you're on host A, and you ssh to host B with X
connection forwarding (ssh -X B), the daemon on host B opens a server
socket bound to 127.0.0.1, port 6010 , then sets up your DISPLAY
variable as localhost:10 (6011, 6012 etc as more connections are made).
So, we have the same problem here as we do with local connections:
127.0.0.1 is localhost _everywhere_, so xauth actually specialcases
any host whose address is 127.0.0.1 in the same way as it does "" and "unix"

In summary, then, the necessary action to open a connection to the
nth ssh-forwarded server on a machine is

  1) obtain authentication data for FamilyLocal, display n+10
  2) open the display at FamilyInternet host localhost port n+6010

darcs-hash:20030209190313-2591e-21921051977c5b3ba91bbd38241e666cb26a6687.gz

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))

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)))
 

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))