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)