diff --git a/contrib/swank-fuzzy.lisp b/contrib/swank-fuzzy.lisp index bfd274fe8..e8114148b 100644 --- a/contrib/swank-fuzzy.lisp +++ b/contrib/swank-fuzzy.lisp @@ -74,7 +74,9 @@ designator's format. The cases are as follows: (zerop time-limit-in-msec))) (time-limit (if no-time-limit-p nil time-limit-in-msec))) (multiple-value-bind (completion-set interrupted-p) - (fuzzy-completion-set string default-package-name :limit limit + ;; Deep down there's a type SIMPLE-STRING required... + (fuzzy-completion-set (coerce string 'simple-string) + default-package-name :limit limit :time-limit-in-msec time-limit) ;; We may send this as elisp [] arrays to spare a coerce here, ;; but then the network serialization were slower by handling arrays. diff --git a/swank.lisp b/swank.lisp index dfdde579c..215227fab 100644 --- a/swank.lisp +++ b/swank.lisp @@ -167,6 +167,10 @@ Backend code should treat the connection structure as opaque.") (indentation-cache-packages '()) ;; The communication style used. (communication-style nil :type (member nil :spawn :sigio :fd-handler)) + ;; A function to interpret packets coming in + (form-decoder nil :type (or null function)) + ;; A function to format outgoing packets + (form-encoder nil :type (or null function)) ) (defun print-connection (conn stream depth) @@ -227,6 +231,13 @@ Backend code should treat the connection structure as opaque.") (defslimefun ping (tag) tag) +(defun set-data-protocol (encoder decoder) + (setf (connection.form-encoder *emacs-connection*) + encoder + (connection.form-decoder *emacs-connection*) + decoder) + T) + (defun safe-backtrace () (ignore-errors (call-with-debugging-environment @@ -248,7 +259,7 @@ to T unless you want to debug swank internals.") (defmacro with-swank-error-handler ((connection) &body body) "Close the connection on internal `swank-error's." - (let ((conn (gensym))) + (let ((conn '*emacs-connection* #+(or) (gensym))) `(let ((,conn ,connection)) (handler-case (handler-bind ((swank-error @@ -710,10 +721,10 @@ If PACKAGE is not specified, the home package of SYMBOL is used." (defun start-server (port-file &key (style *communication-style*) (dont-close *dont-close*)) - "Start the server and write the listen port number to PORT-FILE. + "Start the server and write the listen address and port number to PORT-FILE. This is the entry point for Emacs." (setup-server 0 - (lambda (port) (announce-server-port port-file port)) + (lambda (addr port) (announce-server-port port-file addr port)) style dont-close nil)) (defun create-server (&key (port default-server-port) @@ -754,11 +765,17 @@ e.g.: (restart-loop (http-request url) (use-value (new) (setq url new)))" (ignore-errors (list (parse-integer (read-line *query-io*))))) (setq port new-port)))) +(defun octets-to-ip-string (addr) + (ecase (length addr) + (4 (format nil "~{~d~^.~}" (coerce addr 'list))) + (16 (format nil "~{~2,'0x~2,'0x~^:~}" (coerce addr 'list))))) + (defun setup-server (port announce-fn style dont-close backlog) (init-log-output) (let* ((socket (socket-quest port backlog)) + (addr (octets-to-ip-string (local-addr socket))) (port (local-port socket))) - (funcall announce-fn port) + (funcall announce-fn addr port) (labels ((serve () (accept-connections socket style dont-close)) (note () (send-to-sentinel `(:add-server ,socket ,port ,(current-thread)))) @@ -836,38 +853,49 @@ if the file doesn't exist; otherwise the first line of the file." (:sigio (deinstall-sigio-handler connection)) (:fd-handler (deinstall-fd-handler connection)))))) -(defun announce-server-port (file port) +(defun announce-server-port (file address port) (with-open-file (s file :direction :output :if-exists :error :if-does-not-exist :create) - (format s "~S~%" port)) - (simple-announce-function port)) + (format s "~S ~S~%" address port)) + (simple-announce-function address port)) -(defun simple-announce-function (port) +(defun simple-announce-function (address port) (when *swank-debug-p* - (format *log-output* "~&;; Swank started at port: ~D.~%" port) + (format *log-output* "~&;; Swank started at ~a, port: ~D.~%" address port) (force-output *log-output*))) ;;;;; Event Decoding/Encoding -(defun decode-message (stream) - "Read an S-expression from STREAM using the SLIME protocol." - (log-event "decode-message~%") + +(defun decode-message (stream) ;; =PM + "Read an expression from STREAM." + #+(or) + (format *trace-output* "conn ~a, dec ~a ~%" + *emacs-connection* + (connection.form-decoder *emacs-connection*)) (without-slime-interrupts (handler-bind ((error #'signal-swank-error)) - (handler-case (read-message stream *swank-io-package*) + (handler-case (read-message stream + *swank-io-package* + (lambda () + (connection.form-decoder *emacs-connection*))) + ; =PM (swank-reader-error (c) `(:reader-error ,(swank-reader-error.packet c) ,(swank-reader-error.cause c))))))) (defun encode-message (message stream) - "Write an S-expression to STREAM using the SLIME protocol." + "Write an S-expression to STREAM." (log-event "encode-message~%") (without-slime-interrupts (handler-bind ((error #'signal-swank-error)) - (write-message message *swank-io-package* stream)))) + (write-message message + *swank-io-package* + stream + (connection.form-encoder *emacs-connection*))))) ;;;;; Event Processing @@ -956,6 +984,10 @@ The processing is done in the extent of the toplevel restart." (let ((input-stream (connection.socket-io connection)) (control-thread (mconn.control-thread connection))) (with-swank-error-handler (connection) + ;; PM + ;; Auto-guess communication protocol (S-expr or JSON) + ;; (let ((ch (peek-char input-stream nil nil))) + ;; (when (eql ch #\[))) (loop (send control-thread (decode-message input-stream)))))) (defun dispatch-loop (connection) @@ -1103,7 +1135,7 @@ The processing is done in the extent of the toplevel restart." (defun wait-for-event (pattern &optional timeout) "Scan the event queue for PATTERN and return the event. -If TIMEOUT is 'nil wait until a matching event is enqued. +If TIMEOUT is 'nil wait until a matching event is enqueued. If TIMEOUT is 't only scan the queue without waiting. The second return value is t if the timeout expired before a matching event was found." @@ -2101,7 +2133,7 @@ after Emacs causes a restart to be invoked." "The initial number of backtrace frames to send to Emacs.") (defvar *sldb-restarts* nil - "The list of currenlty active restarts.") + "The list of currently active restarts.") (defvar *sldb-stepping-p* nil "True during execution of a step command.") @@ -2243,7 +2275,7 @@ where restart ::= (name description) stack-frame ::= (number description [plist]) extra ::= (:references and other random things) - cont ::= continutation + cont ::= continuation plist ::= (:restartable {nil | t | :unknown}) condition---a pair of strings: message, and type. If show-source is @@ -2254,7 +2286,7 @@ restart---a pair of strings: restart name, and description. stack-frame---a number from zero (the top), and a printed representation of the frame's call. -continutation---the id of a pending Emacs continuation. +continuation---the id of a pending Emacs continuation. Below is an example return value. In this case the condition was a division by zero (multi-line description), and only one frame is being diff --git a/swank/abcl.lisp b/swank/abcl.lisp index 517b12a99..01a2382de 100644 --- a/swank/abcl.lisp +++ b/swank/abcl.lisp @@ -218,6 +218,9 @@ (defimplementation create-socket (host port &key backlog) (ext:make-server-socket port)) +(defimplementation local-address (socket) + (jcall (jmethod "java.net.ServerSocket" "getLocalAddress") socket)) ;; ?? + (defimplementation local-port (socket) (jcall (jmethod "java.net.ServerSocket" "getLocalPort") socket)) diff --git a/swank/backend.lisp b/swank/backend.lisp index e2bd26d34..8f2833547 100644 --- a/swank/backend.lisp +++ b/swank/backend.lisp @@ -342,6 +342,9 @@ form suitable for testing with #+." "Create a listening TCP socket on interface HOST and port PORT. BACKLOG queue length for incoming connections.") +(definterface local-addr (socket) + "Return the local address used by SOCKET.") + (definterface local-port (socket) "Return the local port number of SOCKET.") diff --git a/swank/clasp.lisp b/swank/clasp.lisp index 5a18ef652..758772cd2 100644 --- a/swank/clasp.lisp +++ b/swank/clasp.lisp @@ -67,6 +67,8 @@ (sb-bsd-sockets:socket-listen socket (or backlog 5)) socket)) +(defimplementation local-addr (socket) + (nth-value 0 (sb-bsd-sockets:socket-name socket))) (defimplementation local-port (socket) (nth-value 1 (sb-bsd-sockets:socket-name socket))) diff --git a/swank/cmucl.lisp b/swank/cmucl.lisp index 8b3d947db..f31be7143 100644 --- a/swank/cmucl.lisp +++ b/swank/cmucl.lisp @@ -67,6 +67,8 @@ (declare (ignore host)) (ext:create-inet-listener port :stream :reuse-address t)) +(defimplementation local-addr (socket) + (nth-value 0 (ext::get-socket-host-and-port (socket-fd socket)))) (defimplementation local-port (socket) (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket)))) diff --git a/swank/ecl.lisp b/swank/ecl.lisp index 0c5bb1ceb..62a60c4b7 100644 --- a/swank/ecl.lisp +++ b/swank/ecl.lisp @@ -84,6 +84,8 @@ (sb-bsd-sockets:socket-listen socket (or backlog 5)) socket)) +(defimplementation local-addr (socket) + (nth-value 0 (sb-bsd-sockets:socket-name socket))) (defimplementation local-port (socket) (nth-value 1 (sb-bsd-sockets:socket-name socket))) diff --git a/swank/lispworks.lisp b/swank/lispworks.lisp index b9d821884..111323eab 100644 --- a/swank/lispworks.lisp +++ b/swank/lispworks.lisp @@ -99,6 +99,8 @@ (list #+unix (lw:get-unix-error errno)) errno)))))) +(defimplementation local-addr (socket) + (nth-value 0 (comm:get-socket-address (socket-fd socket)))) (defimplementation local-port (socket) (nth-value 1 (comm:get-socket-address (socket-fd socket)))) diff --git a/swank/mkcl.lisp b/swank/mkcl.lisp index 3b9df978c..2800e25fa 100644 --- a/swank/mkcl.lisp +++ b/swank/mkcl.lisp @@ -63,6 +63,8 @@ (sb-bsd-sockets:socket-listen socket (or backlog 5)) socket)) +(defimplementation local-addr (socket) + (nth-value 0 (sb-bsd-sockets:socket-name socket))) (defimplementation local-port (socket) (nth-value 1 (sb-bsd-sockets:socket-name socket))) diff --git a/swank/rpc.lisp b/swank/rpc.lisp index e30cc2ccb..0dd167195 100644 --- a/swank/rpc.lisp +++ b/swank/rpc.lisp @@ -8,7 +8,7 @@ ;;; are disclaimed. ;;; -(in-package swank/rpc) +(in-package :swank/rpc) ;;;;; Input @@ -19,12 +19,24 @@ (cause :type reader-error :initarg :cause :reader swank-reader-error.cause))) -(defun read-message (stream package) +(defun read-message (stream package &optional decoder-fn) (let ((packet (read-packet stream))) - (handler-case (values (read-form packet package)) + ;; READ-MESSAGE / DECODE-MESSAGE are run in an asynchronous thread that won't know about the FORM-DECODER slot change when the loop is restarted + (handler-case (values (funcall + (if (eql (aref packet 0) #\[) + (find-symbol "RECOVER-SYMBOLS" (find-package :vlime)) + #'read-form) + #+(or) (or (if decoder-fn + (funcall decoder-fn)) + #'read-form) + #+(or) + (or (and (eql (aref packet 0) #\[) + (funcall decoder-fn)) + #'read-form) + packet package)) (reader-error (c) - (error 'swank-reader-error - :packet packet :cause c))))) + (error 'swank-reader-error + :packet packet :cause c))))) (defun read-packet (stream) (let* ((length (parse-header stream)) @@ -40,6 +52,7 @@ (loop for code across (etypecase packet (string (map 'vector #'char-code packet)) (vector packet)) + ; =PM TODO ignore ยง ? do (cond ((<= code #x7f) (write-char (code-char code))) (t (format t "\\x~x" code)))))) @@ -97,8 +110,10 @@ ;;;;; Output -(defun write-message (message package stream) - (let* ((string (prin1-to-string-for-emacs message package)) +(defun write-message (message package stream &optional encoder) + (let* ((string (funcall (or encoder + #'prin1-to-string-for-emacs) + message package)) (octets (handler-case (swank/backend:string-to-utf8 string) (error (c) (encoding-error c string)))) (length (length octets))) @@ -106,7 +121,7 @@ (write-sequence octets stream) (finish-output stream))) -;; FIXME: for now just tell emacs that we and an encoding problem. +;; FIXME: for now just tell emacs that we had an encoding problem. (defun encoding-error (condition string) (swank/backend:string-to-utf8 (prin1-to-string-for-emacs diff --git a/swank/sbcl.lisp b/swank/sbcl.lisp index a09e04b33..d4752eb35 100644 --- a/swank/sbcl.lisp +++ b/swank/sbcl.lisp @@ -131,6 +131,8 @@ (sb-bsd-sockets:socket-listen socket (or backlog 5)) socket)) +(defimplementation local-addr (socket) + (nth-value 0 (sb-bsd-sockets:socket-name socket))) (defimplementation local-port (socket) (nth-value 1 (sb-bsd-sockets:socket-name socket))) diff --git a/swank/scl.lisp b/swank/scl.lisp index ac68c8e5d..6ebf64675 100644 --- a/swank/scl.lisp +++ b/swank/scl.lisp @@ -34,6 +34,8 @@ (ext:create-inet-listener port :stream :host addr :reuse-address t :backlog (or backlog 5)))) +(defimplementation local-addr (socket) + (nth-value 0 (ext::get-socket-host-and-port (socket-fd socket)))) (defimplementation local-port (socket) (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket))))