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

Contents of /slime/swank-rpc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (hide annotations)
Sun Dec 4 15:44:08 2011 UTC (2 years, 4 months ago) by heller
Branch: MAIN
Changes since 1.10: +0 -1 lines
* swank.lisp: Minor cleanups.
* swank-rpc.lisp:
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.9 (let* ((length (parse-header stream))
40     (octets (read-chunk stream length)))
41     (handler-case (swank-backend:utf8-to-string octets)
42     (error (c)
43     (error (make-condition 'swank-reader-error
44     :packet (asciify octets)
45     :cause c))))))
46 heller 1.8
47     (defun asciify (packet)
48     (with-output-to-string (*standard-output*)
49     (loop for code across (etypecase packet
50     (string (map 'vector #'char-code packet))
51     (vector packet))
52     do (cond ((<= code #x7f) (write-char (code-char code)))
53     (t (format t "\\x~x" code))))))
54    
55     (defun parse-header (stream)
56 heller 1.9 (parse-integer (map 'string #'code-char (read-chunk stream 6))
57     :radix 16))
58    
59 heller 1.6 (defun read-chunk (stream length)
60 heller 1.8 (let* ((buffer (make-array length :element-type '(unsigned-byte 8)))
61 heller 1.6 (count (read-sequence buffer stream)))
62 heller 1.10 (cond ((= count length)
63     buffer)
64     ((zerop count)
65     (error (make-condition 'end-of-file :stream stream)))
66     (t
67     (error "Short read: length=~D count=~D" length count)))))
68 heller 1.6
69     ;; FIXME: no one ever tested this and will probably not work.
70     (defparameter *validate-input* nil
71     "Set to true to require input that strictly conforms to the protocol")
72    
73     (defun read-form (string package)
74     (with-standard-io-syntax
75     (let ((*package* package))
76     (if *validate-input*
77     (validating-read string)
78     (read-from-string string)))))
79    
80     (defun validating-read (string)
81     (with-input-from-string (*standard-input* string)
82     (simple-read)))
83    
84 tnorderhaug 1.1 (defun simple-read ()
85 heller 1.6 "Read a form that conforms to the protocol, otherwise signal an error."
86 tnorderhaug 1.1 (let ((c (read-char)))
87     (case c
88     (#\" (with-output-to-string (*standard-output*)
89     (loop for c = (read-char) do
90     (case c
91     (#\" (return))
92     (#\\ (write-char (read-char)))
93     (t (write-char c))))))
94     (#\( (loop collect (simple-read)
95     while (ecase (read-char)
96     (#\) nil)
97     (#\space t))))
98     (#\' `(quote ,(simple-read)))
99     (t (let ((string (with-output-to-string (*standard-output*)
100     (loop for ch = c then (read-char nil nil) do
101     (case ch
102     ((nil) (return))
103     (#\\ (write-char (read-char)))
104     ((#\space #\)) (unread-char ch)(return))
105     (t (write-char ch)))))))
106     (cond ((digit-char-p c) (parse-integer string))
107     ((intern string))))))))
108    
109 heller 1.6
110 tnorderhaug 1.1 ;;;;; Output
111    
112 heller 1.6 (defun write-message (message package stream)
113     (let* ((string (prin1-to-string-for-emacs message package))
114 heller 1.8 (octets (handler-case (swank-backend:string-to-utf8 string)
115     (error (c) (encoding-error c string))))
116     (length (length octets)))
117 heller 1.9 (write-header stream length)
118 heller 1.8 (write-sequence octets stream)
119 heller 1.6 (finish-output stream)))
120 tnorderhaug 1.1
121 heller 1.8 ;; FIXME: for now just tell emacs that we and an encoding problem.
122     (defun encoding-error (condition string)
123     (swank-backend:string-to-utf8
124     (prin1-to-string-for-emacs
125     `(:reader-error
126     ,(asciify string)
127     ,(format nil "Error during string-to-utf8: ~a"
128     (or (ignore-errors (asciify (princ-to-string condition)))
129     (asciify (princ-to-string (type-of condition))))))
130     (find-package :cl))))
131    
132 heller 1.9 (defun write-header (stream length)
133     (declare (type (unsigned-byte 24) length))
134     ;;(format *trace-output* "length: ~d (#x~x)~%" length length)
135     (loop for c across (format nil "~6,'0x" length)
136     do (write-byte (char-code c) stream)))
137 heller 1.8
138 heller 1.6 (defun prin1-to-string-for-emacs (object package)
139 tnorderhaug 1.1 (with-standard-io-syntax
140     (let ((*print-case* :downcase)
141     (*print-readably* nil)
142     (*print-pretty* nil)
143 heller 1.6 (*package* package))
144 tnorderhaug 1.1 (prin1-to-string object))))
145    
146 heller 1.6
147 tnorderhaug 1.1 #| TEST/DEMO:
148    
149     (defparameter *transport*
150     (with-output-to-string (out)
151 heller 1.6 (write-message '(:message (hello "world")) *package* out)
152     (write-message '(:return 5) *package* out)
153     (write-message '(:emacs-rex NIL) *package* out)))
154 tnorderhaug 1.1
155     *transport*
156    
157     (with-input-from-string (in *transport*)
158     (loop while (peek-char T in NIL)
159 heller 1.6 collect (read-message in *package*)))
160 tnorderhaug 1.1
161     |#

  ViewVC Help
Powered by ViewVC 1.1.5