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

Contents of /slime/swank-rpc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (hide annotations)
Wed Apr 14 17:51:30 2010 UTC (4 years ago) by heller
Branch: MAIN
Changes since 1.5: +63 -211 lines
Move error handling and logging from swank-rpc.lisp to swank.lisp

* swank.lisp (log-event, destructure-case, decode-message)
(encode-message, decode-message, swank-protocol-error): Moved back
to swank.lisp from swank-rpc.lisp.  It never belonged there
anyway.

* swank-rpc.lisp (read-message, write-message): New functions.
(swank-reader-error): New condition.
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     ((packet :type string :initarg :packet :reader swank-reader-error.packet)
27     (cause :type reader-error :initarg :cause :reader swank-reader-error.cause)))
28    
29     (defun read-message (stream package)
30     (let ((packet (read-packet stream)))
31     (handler-case (values (read-form packet package))
32     (reader-error (c)
33     (error (make-condition 'swank-reader-error :packet packet :cause c))))))
34    
35     ;; use peek-char to detect EOF, read-sequence may return 0 instead of
36     ;; signaling a condition.
37     (defun read-packet (stream)
38     (peek-char nil stream)
39     (let* ((header (read-chunk stream 6))
40     (length (parse-integer header :radix #x10))
41     (payload (read-chunk stream length)))
42     payload))
43    
44     (defun read-chunk (stream length)
45     (let* ((buffer (make-string length))
46     (count (read-sequence buffer stream)))
47     (assert (= count length) () "Short read: length=~D count=~D" length count)
48     buffer))
49    
50     ;; FIXME: no one ever tested this and will probably not work.
51     (defparameter *validate-input* nil
52     "Set to true to require input that strictly conforms to the protocol")
53    
54     (defun read-form (string package)
55     (with-standard-io-syntax
56     (let ((*package* package))
57     (if *validate-input*
58     (validating-read string)
59     (read-from-string string)))))
60    
61     (defun validating-read (string)
62     (with-input-from-string (*standard-input* string)
63     (simple-read)))
64    
65 tnorderhaug 1.1 (defun simple-read ()
66 heller 1.6 "Read a form that conforms to the protocol, otherwise signal an error."
67 tnorderhaug 1.1 (let ((c (read-char)))
68     (case c
69     (#\" (with-output-to-string (*standard-output*)
70     (loop for c = (read-char) do
71     (case c
72     (#\" (return))
73     (#\\ (write-char (read-char)))
74     (t (write-char c))))))
75     (#\( (loop collect (simple-read)
76     while (ecase (read-char)
77     (#\) nil)
78     (#\space t))))
79     (#\' `(quote ,(simple-read)))
80     (t (let ((string (with-output-to-string (*standard-output*)
81     (loop for ch = c then (read-char nil nil) do
82     (case ch
83     ((nil) (return))
84     (#\\ (write-char (read-char)))
85     ((#\space #\)) (unread-char ch)(return))
86     (t (write-char ch)))))))
87     (cond ((digit-char-p c) (parse-integer string))
88     ((intern string))))))))
89    
90 heller 1.6
91 tnorderhaug 1.1 ;;;;; Output
92    
93 heller 1.6 (defun write-message (message package stream)
94     (let* ((string (prin1-to-string-for-emacs message package))
95     (length (length string)))
96     (let ((*print-pretty* nil))
97     (format stream "~6,'0x" length))
98     (write-string string stream)
99     (finish-output stream)))
100 tnorderhaug 1.1
101 heller 1.6 (defun prin1-to-string-for-emacs (object package)
102 tnorderhaug 1.1 (with-standard-io-syntax
103     (let ((*print-case* :downcase)
104     (*print-readably* nil)
105     (*print-pretty* nil)
106 heller 1.6 (*package* package))
107 tnorderhaug 1.1 (prin1-to-string object))))
108    
109 heller 1.6
110 tnorderhaug 1.1 #| TEST/DEMO:
111    
112     (defparameter *transport*
113     (with-output-to-string (out)
114 heller 1.6 (write-message '(:message (hello "world")) *package* out)
115     (write-message '(:return 5) *package* out)
116     (write-message '(:emacs-rex NIL) *package* out)))
117 tnorderhaug 1.1
118     *transport*
119    
120     (with-input-from-string (in *transport*)
121     (loop while (peek-char T in NIL)
122 heller 1.6 collect (read-message in *package*)))
123 tnorderhaug 1.1
124     |#

  ViewVC Help
Powered by ViewVC 1.1.5