[mcclim-cvs] CVS update: mcclim/Backends/CLX/port.lisp

[Christophe Rhodes]

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX
In directory common-lisp.net:/tmp/cvs-serv9380/Backends/CLX

Modified Files:
	port.lisp 
Log Message:
Fix clim-over-ssh-x-fails, by parsing $DISPLAY more correctly.

Date: Sun Apr  3 00:18:21 2005
Author: crhodes

Index: mcclim/Backends/CLX/port.lisp
diff -u mcclim/Backends/CLX/port.lisp:1.109 mcclim/Backends/CLX/port.lisp:1.110
--- mcclim/Backends/CLX/port.lisp:1.109	Tue Mar 22 13:31:22 2005
+++ mcclim/Backends/CLX/port.lisp	Sun Apr  3 00:18:20 2005
@@ -170,16 +170,33 @@
 
 (defun parse-clx-server-path (path)
   (pop path)
-  (let* ((s (get-environment-variable "DISPLAY"))
-	 (colon (position #\: s))
-	 (dot (position #\. s :start colon))
-	 (host-name (subseq s 0 colon))
-	 (display-number (parse-integer s :start (1+ colon) :end dot))
-	 (screen-number (if dot (parse-integer s :start (1+ dot)) 0)))
+  (let* ((name (get-environment-variable "DISPLAY"))
+	 ;; this code courtesy telent-clx.
+         (slash-i (or (position #\/ name) -1))
+         (colon-i (position #\: name :start (1+ slash-i)))
+         (decnet-colon-p (eql (elt name (1+ colon-i)) #\:))
+         (host (subseq name (1+ slash-i) colon-i))
+         (dot-i (and colon-i (position #\. name :start colon-i)))
+         (display (when colon-i
+                    (parse-integer name
+                                   :start (if decnet-colon-p
+                                              (+ colon-i 2)
+					      (1+ colon-i))
+                                   :end dot-i)))
+         (screen (when dot-i
+                   (parse-integer name :start (1+ dot-i))))
+         (protocol
+          (cond ((or (string= host "") (string-equal host "unix")) :local)
+                (decnet-colon-p :decnet)
+                ((> slash-i -1) (intern
+                                 (string-upcase (subseq name 0 slash-i))
+                                 :keyword))
+                (t :internet))))
     (list :clx
-	  :host (getf path :host host-name)
-	  :display-id (getf path :display-id display-number)
-	  :screen-id (getf path :screen-id screen-number))))
+	  :host (getf path :host host)
+	  :display-id (getf path :display-id display)
+	  :screen-id (getf path :screen-id screen)
+	  :protocol protocol)))
 
 (setf (get :x11 :port-type) 'clx-port)
 (setf (get :x11 :server-path-parser) 'parse-clx-server-path)
@@ -251,7 +268,7 @@
 (defmethod initialize-clx ((port clx-port))
   (let ((options (cdr (port-server-path port))))
     (setf (clx-port-display port)
-	  (xlib:open-display (getf options :host "") :display (getf options :display-id 0)))
+	  (xlib:open-display (getf options :host "") :display (getf options :display-id 0) :protocol (getf options :protocol :local)))
     (progn
       (setf (xlib:display-error-handler (clx-port-display port))
         #'clx-error-handler)