Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 162 lines (135 sloc) 5.399 kb
d9f4c9f * swank.lisp, swank-rpc.lisp: iso-8859-1 is not same as latin-1-unix.
Helmut Eller authored
1 ;;; -*- indent-tabs-mode: nil; coding: latin-1-unix -*-
0b55401 Refactorizing RPC layer into new module.
Terje Norderhaug authored
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
8a173d0 Move error handling and logging from swank-rpc.lisp to swank.lisp
Helmut Eller authored
11 (defpackage #:swank-rpc
f0db18f Stas Boukarev * swank-rpc.lisp (:swank-rpc): (:use :cl), SBCL
stassats authored
12 (:use :cl)
52382e8 New swank-rpc package
Terje Norderhaug authored
13 (:export
8a173d0 Move error handling and logging from swank-rpc.lisp to swank.lisp
Helmut Eller authored
14 #:read-message
15 #:swank-reader-error
16 #:swank-reader-error.packet
17 #:swank-reader-error.cause
18 #:write-message))
52382e8 New swank-rpc package
Terje Norderhaug authored
19
20 (in-package :swank-rpc)
0b55401 Refactorizing RPC layer into new module.
Terje Norderhaug authored
21
8a173d0 Move error handling and logging from swank-rpc.lisp to swank.lisp
Helmut Eller authored
22
0b55401 Refactorizing RPC layer into new module.
Terje Norderhaug authored
23 ;;;;; Input
24
8a173d0 Move error handling and logging from swank-rpc.lisp to swank.lisp
Helmut Eller authored
25 (define-condition swank-reader-error (reader-error)
82a58ff New wire format.
Helmut Eller authored
26 ((packet :type string :initarg :packet
27 :reader swank-reader-error.packet)
28 (cause :type reader-error :initarg :cause
29 :reader swank-reader-error.cause)))
8a173d0 Move error handling and logging from swank-rpc.lisp to swank.lisp
Helmut Eller authored
30
31 (defun read-message (stream package)
32 (let ((packet (read-packet stream)))
33 (handler-case (values (read-form packet package))
34 (reader-error (c)
c6b4fd5 Stas Boukarev * clean up: (signal (make-condition ...)) => (signal ...)
stassats authored
35 (error 'swank-reader-error
36 :packet packet :cause c)))))
8a173d0 Move error handling and logging from swank-rpc.lisp to swank.lisp
Helmut Eller authored
37
38 (defun read-packet (stream)
a8a5b81 Restore old header format.
Helmut Eller authored
39 (let* ((length (parse-header stream))
40 (octets (read-chunk stream length)))
41 (handler-case (swank-backend:utf8-to-string octets)
42 (error (c)
c6b4fd5 Stas Boukarev * clean up: (signal (make-condition ...)) => (signal ...)
stassats authored
43 (error 'swank-reader-error
44 :packet (asciify octets)
45 :cause c)))))
82a58ff New wire format.
Helmut Eller authored
46
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)
a8a5b81 Restore old header format.
Helmut Eller authored
56 (parse-integer (map 'string #'code-char (read-chunk stream 6))
57 :radix 16))
58
8a173d0 Move error handling and logging from swank-rpc.lisp to swank.lisp
Helmut Eller authored
59 (defun read-chunk (stream length)
82a58ff New wire format.
Helmut Eller authored
60 (let* ((buffer (make-array length :element-type '(unsigned-byte 8)))
8a173d0 Move error handling and logging from swank-rpc.lisp to swank.lisp
Helmut Eller authored
61 (count (read-sequence buffer stream)))
4ebeb78 * swank-rpc.lisp (read-chunk): Signal end-of-file we had no input.
Helmut Eller authored
62 (cond ((= count length)
63 buffer)
64 ((zerop count)
c6b4fd5 Stas Boukarev * clean up: (signal (make-condition ...)) => (signal ...)
stassats authored
65 (error 'end-of-file :stream stream))
4ebeb78 * swank-rpc.lisp (read-chunk): Signal end-of-file we had no input.
Helmut Eller authored
66 (t
67 (error "Short read: length=~D count=~D" length count)))))
8a173d0 Move error handling and logging from swank-rpc.lisp to swank.lisp
Helmut Eller authored
68
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
0b55401 Refactorizing RPC layer into new module.
Terje Norderhaug authored
84 (defun simple-read ()
8a173d0 Move error handling and logging from swank-rpc.lisp to swank.lisp
Helmut Eller authored
85 "Read a form that conforms to the protocol, otherwise signal an error."
0b55401 Refactorizing RPC layer into new module.
Terje Norderhaug authored
86 (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
8a173d0 Move error handling and logging from swank-rpc.lisp to swank.lisp
Helmut Eller authored
109
0b55401 Refactorizing RPC layer into new module.
Terje Norderhaug authored
110 ;;;;; Output
111
8a173d0 Move error handling and logging from swank-rpc.lisp to swank.lisp
Helmut Eller authored
112 (defun write-message (message package stream)
113 (let* ((string (prin1-to-string-for-emacs message package))
82a58ff New wire format.
Helmut Eller authored
114 (octets (handler-case (swank-backend:string-to-utf8 string)
115 (error (c) (encoding-error c string))))
116 (length (length octets)))
a8a5b81 Restore old header format.
Helmut Eller authored
117 (write-header stream length)
82a58ff New wire format.
Helmut Eller authored
118 (write-sequence octets stream)
8a173d0 Move error handling and logging from swank-rpc.lisp to swank.lisp
Helmut Eller authored
119 (finish-output stream)))
0b55401 Refactorizing RPC layer into new module.
Terje Norderhaug authored
120
82a58ff New wire format.
Helmut Eller authored
121 ;; 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
a8a5b81 Restore old header format.
Helmut Eller authored
132 (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)))
82a58ff New wire format.
Helmut Eller authored
137
8a173d0 Move error handling and logging from swank-rpc.lisp to swank.lisp
Helmut Eller authored
138 (defun prin1-to-string-for-emacs (object package)
0b55401 Refactorizing RPC layer into new module.
Terje Norderhaug authored
139 (with-standard-io-syntax
140 (let ((*print-case* :downcase)
141 (*print-readably* nil)
142 (*print-pretty* nil)
8a173d0 Move error handling and logging from swank-rpc.lisp to swank.lisp
Helmut Eller authored
143 (*package* package))
0b55401 Refactorizing RPC layer into new module.
Terje Norderhaug authored
144 (prin1-to-string object))))
145
8a173d0 Move error handling and logging from swank-rpc.lisp to swank.lisp
Helmut Eller authored
146
0b55401 Refactorizing RPC layer into new module.
Terje Norderhaug authored
147 #| TEST/DEMO:
148
149 (defparameter *transport*
150 (with-output-to-string (out)
8a173d0 Move error handling and logging from swank-rpc.lisp to swank.lisp
Helmut Eller authored
151 (write-message '(:message (hello "world")) *package* out)
152 (write-message '(:return 5) *package* out)
153 (write-message '(:emacs-rex NIL) *package* out)))
0b55401 Refactorizing RPC layer into new module.
Terje Norderhaug authored
154
155 *transport*
156
157 (with-input-from-string (in *transport*)
158 (loop while (peek-char T in NIL)
8a173d0 Move error handling and logging from swank-rpc.lisp to swank.lisp
Helmut Eller authored
159 collect (read-message in *package*)))
0b55401 Refactorizing RPC layer into new module.
Terje Norderhaug authored
160
161 |#
Something went wrong with that request. Please try again.