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

Contents of /slime/swank-rpc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5