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

Contents of /slime/swank-rpc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide annotations)
Mon Jan 18 23:20:34 2010 UTC (4 years, 2 months ago) by tnorderhaug
Branch: MAIN
Refactorizing RPC layer into new module.
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     (in-package :swank)
12    
13     ;;;;; Input
14    
15     (defun simple-read ()
16     "Reads a form that conforms to the protocol, otherwise signalling an error."
17     (let ((c (read-char)))
18     (case c
19     (#\" (with-output-to-string (*standard-output*)
20     (loop for c = (read-char) do
21     (case c
22     (#\" (return))
23     (#\\ (write-char (read-char)))
24     (t (write-char c))))))
25     (#\( (loop collect (simple-read)
26     while (ecase (read-char)
27     (#\) nil)
28     (#\space t))))
29     (#\' `(quote ,(simple-read)))
30     (t (let ((string (with-output-to-string (*standard-output*)
31     (loop for ch = c then (read-char nil nil) do
32     (case ch
33     ((nil) (return))
34     (#\\ (write-char (read-char)))
35     ((#\space #\)) (unread-char ch)(return))
36     (t (write-char ch)))))))
37     (cond ((digit-char-p c) (parse-integer string))
38     ((intern string))))))))
39    
40     (defun decode-message (stream)
41     "Read an S-expression from STREAM using the SLIME protocol."
42     ;;(log-event "decode-message~%")
43     (handler-bind ((error (lambda (c) (error (make-swank-protocol-error c)))))
44     (let ((packet (read-packet stream)))
45     (handler-case (values (read-form packet) nil)
46     (reader-error (c)
47     `(:reader-error ,packet ,c))))))
48    
49     ;; use peek-char to detect EOF, read-sequence may return 0 instead of
50     ;; signaling a condition.
51     (defun read-packet (stream)
52     (peek-char nil stream)
53     (let* ((header (read-chunk stream 6))
54     (length (parse-integer header :radix #x10))
55     (payload (read-chunk stream length)))
56     (log-event "READ: ~S~%" payload)
57     payload))
58    
59     (defun read-chunk (stream length)
60     (let* ((buffer (make-string length))
61     (count (read-sequence buffer stream)))
62     (assert (= count length) () "Short read: length=~D count=~D" length count)
63     buffer))
64    
65     (defvar *swank-io-package*
66     (let ((package (make-package :swank-io-package :use '())))
67     (import '(nil t quote) package)
68     package))
69    
70     (defparameter *validate-input* NIL
71     "Set to true to require input that strictly conforms to the protocol")
72    
73     (defun read-form (string)
74     (with-standard-io-syntax
75     (let ((*package* *swank-io-package*))
76     (if *validate-input*
77     (with-input-from-string (*standard-input* string)
78     (simple-read))
79     (read-from-string string)))))
80    
81     ;;;;; Output
82    
83     (defun encode-message (message stream)
84     (handler-bind ((error (lambda (c) (error (make-swank-protocol-error c)))))
85     (let* ((string (prin1-to-string-for-emacs message))
86     (length (length string)))
87     (log-event "WRITE: ~A~%" string)
88     (let ((*print-pretty* nil))
89     (format stream "~6,'0x" length))
90     (write-string string stream)
91     (finish-output stream))))
92    
93     (defun prin1-to-string-for-emacs (object)
94     (with-standard-io-syntax
95     (let ((*print-case* :downcase)
96     (*print-readably* nil)
97     (*print-pretty* nil)
98     (*package* *swank-io-package*))
99     (prin1-to-string object))))
100    
101     ;;;;; message decomposition
102    
103     (defmacro destructure-case (value &rest patterns)
104     "Dispatch VALUE to one of PATTERNS.
105     A cross between `case' and `destructuring-bind'.
106     The pattern syntax is:
107     ((HEAD . ARGS) . BODY)
108     The list of patterns is searched for a HEAD `eq' to the car of
109     VALUE. If one is found, the BODY is executed with ARGS bound to the
110     corresponding values in the CDR of VALUE."
111     (let ((operator (gensym "op-"))
112     (operands (gensym "rand-"))
113     (tmp (gensym "tmp-")))
114     `(let* ((,tmp ,value)
115     (,operator (car ,tmp))
116     (,operands (cdr ,tmp)))
117     (case ,operator
118     ,@(loop for (pattern . body) in patterns collect
119     (if (eq pattern t)
120     `(t ,@body)
121     (destructuring-bind (op &rest rands) pattern
122     `(,op (destructuring-bind ,rands ,operands
123     ,@body)))))
124     ,@(if (eq (caar (last patterns)) t)
125     '()
126     `((t (error "destructure-case failed: ~S" ,tmp))))))))
127    
128     ;;;;; Error handling
129    
130     ;; A condition to include backtrace information
131     (define-condition swank-protocol-error (error)
132     ((condition :initarg :condition :reader swank-protocol-error.condition)
133     (backtrace :initarg :backtrace :reader swank-protocol-error.backtrace))
134     (:report (lambda (condition stream)
135     (princ (swank-protocol-error.condition condition) stream))))
136    
137     (defun make-swank-protocol-error (condition)
138     (make-condition 'swank-protocol-error :condition condition
139     :backtrace (safe-backtrace)))
140    
141     ;;;;; Logging
142    
143     (defvar *log-events* nil)
144     (defvar *log-output* nil) ; should be nil for image dumpers
145    
146     (defun init-log-output ()
147     (unless *log-output*
148     (setq *log-output* (real-output-stream *error-output*))))
149    
150     (defun real-input-stream (stream)
151     (typecase stream
152     (synonym-stream
153     (real-input-stream (symbol-value (synonym-stream-symbol stream))))
154     (two-way-stream
155     (real-input-stream (two-way-stream-input-stream stream)))
156     (t stream)))
157    
158     (defun real-output-stream (stream)
159     (typecase stream
160     (synonym-stream
161     (real-output-stream (symbol-value (synonym-stream-symbol stream))))
162     (two-way-stream
163     (real-output-stream (two-way-stream-output-stream stream)))
164     (t stream)))
165    
166     (defvar *event-history* (make-array 40 :initial-element nil)
167     "A ring buffer to record events for better error messages.")
168     (defvar *event-history-index* 0)
169     (defvar *enable-event-history* t)
170    
171     (defun log-event (format-string &rest args)
172     "Write a message to *terminal-io* when *log-events* is non-nil.
173     Useful for low level debugging."
174     (with-standard-io-syntax
175     (let ((*print-readably* nil)
176     (*print-pretty* nil)
177     (*package* *swank-io-package*))
178     (when *enable-event-history*
179     (setf (aref *event-history* *event-history-index*)
180     (format nil "~?" format-string args))
181     (setf *event-history-index*
182     (mod (1+ *event-history-index*) (length *event-history*))))
183     (when *log-events*
184     (write-string (escape-non-ascii (format nil "~?" format-string args))
185     *log-output*)
186     (force-output *log-output*)))))
187    
188     (defun event-history-to-list ()
189     "Return the list of events (older events first)."
190     (let ((arr *event-history*)
191     (idx *event-history-index*))
192     (concatenate 'list (subseq arr idx) (subseq arr 0 idx))))
193    
194     (defun clear-event-history ()
195     (fill *event-history* nil)
196     (setq *event-history-index* 0))
197    
198     (defun dump-event-history (stream)
199     (dolist (e (event-history-to-list))
200     (dump-event e stream)))
201    
202     (defun dump-event (event stream)
203     (cond ((stringp event)
204     (write-string (escape-non-ascii event) stream))
205     ((null event))
206     (t
207     (write-string
208     (escape-non-ascii (format nil "Unexpected event: ~A~%" event))
209     stream))))
210    
211     (defun escape-non-ascii (string)
212     "Return a string like STRING but with non-ascii chars escaped."
213     (cond ((ascii-string-p string) string)
214     (t (with-output-to-string (out)
215     (loop for c across string do
216     (cond ((ascii-char-p c) (write-char c out))
217     (t (format out "\\x~4,'0X" (char-code c)))))))))
218    
219     (defun ascii-string-p (o)
220     (and (stringp o)
221     (every #'ascii-char-p o)))
222    
223     (defun ascii-char-p (c)
224     (<= (char-code c) 127))
225    
226    
227     #| TEST/DEMO:
228    
229     (setf *log-events* T)
230    
231     (defparameter *transport*
232     (with-output-to-string (out)
233     (encode-message '(:message (hello "world")) out)
234     (encode-message '(:return 5) out)
235     (encode-message '(:emacs-rex NIL) out)))
236    
237     *transport*
238    
239     (with-input-from-string (in *transport*)
240     (loop while (peek-char T in NIL)
241     collect (decode-message in)))
242    
243     |#

  ViewVC Help
Powered by ViewVC 1.1.5