/[slime]/slime/swank-rpc.lisp
ViewVC logotype

Contents of /slime/swank-rpc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (hide annotations)
Sun Nov 6 17:06:09 2011 UTC (2 years, 5 months ago) by heller
Branch: MAIN
Changes since 1.7: +57 -16 lines
New wire format.

Switch from character streams to binary streams.  Counting
characters was error prone because some Lisps use utf-16
internally and so READ-SEQUENCE can't be used easily.

The new format looks so:

  | byte0 | 3 bytes length |
  |    ... payload ...     |

The playload is an s-exp encoded as UTF-8 string.  byte0 is
currently always 0; other values are reserved for future use.

* swank-rpc.lisp (write-message): Use new format.
(write-header, parse-header, asciify, encoding-error): New.

* swank.lisp (accept-connections): Create a binary stream.
(input-available-p): Can't read-char-no-hang on binary streams.

* slime.el (slime-net-connect): Use binary as coding system.
(slime-net-send, slime-net-read, slime-net-decode-length)
(slime-net-encode-length, slime-net-have-input-p): Use new format.
(slime-unibyte-string, slime-handle-net-read-error): New.
(featurep): Require 'un-define for XEmacs.
([test] break): Longer timeouts.

* swank-sbcl.lisp (input-ready-p): Use sb-sys:wait-until-fd-usable.
1 tnorderhaug 1.1 ;;; -*- indent-tabs-mode:nil coding:latin-1-unix -*-
2     ;;;
3     ;;; swank-rpc.lisp -- Pass remote calls and responses between lisp systems.
4     ;;;
5     ;;; Created 2010, Terje Norderhaug <terje@in-progress.com>
6     ;;;
7     ;;; This code has been placed in the Public Domain. All warranties
8     ;;; are disclaimed.
9     ;;;
10    
11 heller 1.6 (defpackage #:swank-rpc
12 sboukarev 1.3 (:use :cl)
13 tnorderhaug 1.2 (:export
14 heller 1.6 #:read-message
15     #:swank-reader-error
16     #:swank-reader-error.packet
17     #:swank-reader-error.cause
18     #:write-message))
19 tnorderhaug 1.2
20     (in-package :swank-rpc)
21 tnorderhaug 1.1
22 heller 1.6
23 tnorderhaug 1.1 ;;;;; Input
24    
25 heller 1.6 (define-condition swank-reader-error (reader-error)
26 heller 1.8 ((packet :type string :initarg :packet
27     :reader swank-reader-error.packet)
28     (cause :type reader-error :initarg :cause
29     :reader swank-reader-error.cause)))
30 heller 1.6
31     (defun read-message (stream package)
32     (let ((packet (read-packet stream)))
33     (handler-case (values (read-form packet package))
34     (reader-error (c)
35 heller 1.8 (error (make-condition 'swank-reader-error
36     :packet packet :cause c))))))
37 heller 1.6
38     (defun read-packet (stream)
39 heller 1.8 (multiple-value-bind (byte0 length) (parse-header stream)
40     (cond ((= byte0 0)
41     (let ((octets (read-chunk stream length)))
42     (handler-case (swank-backend:utf8-to-string octets)
43     (error (c)
44     (error (make-condition 'swank-reader-error
45     :packet (asciify octets)
46     :cause c))))))
47     (t
48     (error "Invalid header byte0 #b~b" byte0)))))
49    
50     (defun asciify (packet)
51     (with-output-to-string (*standard-output*)
52     (loop for code across (etypecase packet
53     (string (map 'vector #'char-code packet))
54     (vector packet))
55     do (cond ((<= code #x7f) (write-char (code-char code)))
56     (t (format t "\\x~x" code))))))
57    
58     (defun parse-header (stream)
59     (values (read-byte stream)
60     (logior (ash (read-byte stream) 16)
61     (ash (read-byte stream) 8)
62     (read-byte stream))))
63    
64 heller 1.6 (defun read-chunk (stream length)
65 heller 1.8 (let* ((buffer (make-array length :element-type '(unsigned-byte 8)))
66 heller 1.6 (count (read-sequence buffer stream)))
67     (assert (= count length) () "Short read: length=~D count=~D" length count)
68     buffer))
69    
70     ;; FIXME: no one ever tested this and will probably not work.
71     (defparameter *validate-input* nil
72     "Set to true to require input that strictly conforms to the protocol")
73    
74     (defun read-form (string package)
75     (with-standard-io-syntax
76     (let ((*package* package))
77     (if *validate-input*
78     (validating-read string)
79     (read-from-string string)))))
80    
81     (defun validating-read (string)
82     (with-input-from-string (*standard-input* string)
83     (simple-read)))
84    
85 tnorderhaug 1.1 (defun simple-read ()
86 heller 1.6 "Read a form that conforms to the protocol, otherwise signal an error."
87 tnorderhaug 1.1 (let ((c (read-char)))
88     (case c
89     (#\" (with-output-to-string (*standard-output*)
90     (loop for c = (read-char) do
91     (case c
92     (#\" (return))
93     (#\\ (write-char (read-char)))
94     (t (write-char c))))))
95     (#\( (loop collect (simple-read)
96     while (ecase (read-char)
97     (#\) nil)
98     (#\space t))))
99     (#\' `(quote ,(simple-read)))
100     (t (let ((string (with-output-to-string (*standard-output*)
101     (loop for ch = c then (read-char nil nil) do
102     (case ch
103     ((nil) (return))
104     (#\\ (write-char (read-char)))
105     ((#\space #\)) (unread-char ch)(return))
106     (t (write-char ch)))))))
107     (cond ((digit-char-p c) (parse-integer string))
108     ((intern string))))))))
109    
110 heller 1.6
111 tnorderhaug 1.1 ;;;;; Output
112    
113 heller 1.6 (defun write-message (message package stream)
114     (let* ((string (prin1-to-string-for-emacs message package))
115 heller 1.8 (octets (handler-case (swank-backend:string-to-utf8 string)
116     (error (c) (encoding-error c string))))
117     (length (length octets)))
118     (write-header stream 0 length)
119     (write-sequence octets stream)
120 heller 1.6 (finish-output stream)))
121 tnorderhaug 1.1
122 heller 1.8 ;; FIXME: for now just tell emacs that we and an encoding problem.
123     (defun encoding-error (condition string)
124     (swank-backend:string-to-utf8
125     (prin1-to-string-for-emacs
126     `(:reader-error
127     ,(asciify string)
128     ,(format nil "Error during string-to-utf8: ~a"
129     (or (ignore-errors (asciify (princ-to-string condition)))
130     (asciify (princ-to-string (type-of condition))))))
131     (find-package :cl))))
132    
133     (defun write-header (stream byte0 length)
134     (declare (type (unsigned-byte 8) byte0)
135     (type (unsigned-byte 24) length))
136     ;;(format *trace-output* "byte0: ~d length: ~d (#x~x)~%" byte0 length length)
137     (write-byte byte0 stream)
138     (write-byte (ldb (byte 8 16) length) stream)
139     (write-byte (ldb (byte 8 8) length) stream)
140     (write-byte (ldb (byte 8 0) length) stream))
141    
142 heller 1.6 (defun prin1-to-string-for-emacs (object package)
143 tnorderhaug 1.1 (with-standard-io-syntax
144     (let ((*print-case* :downcase)
145     (*print-readably* nil)
146     (*print-pretty* nil)
147 heller 1.6 (*package* package))
148 tnorderhaug 1.1 (prin1-to-string object))))
149    
150 heller 1.6
151 tnorderhaug 1.1 #| TEST/DEMO:
152    
153     (defparameter *transport*
154     (with-output-to-string (out)
155 heller 1.6 (write-message '(:message (hello "world")) *package* out)
156     (write-message '(:return 5) *package* out)
157     (write-message '(:emacs-rex NIL) *package* out)))
158 tnorderhaug 1.1
159     *transport*
160    
161     (with-input-from-string (in *transport*)
162     (loop while (peek-char T in NIL)
163 heller 1.6 collect (read-message in *package*)))
164 tnorderhaug 1.1
165     |#

  ViewVC Help
Powered by ViewVC 1.1.5