blob: 5f40a574cb6e463a257fe1a9c3501368ae50922f (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
|
;;; This code has been placed in the Public Domain. All warranties are disclaimed.
(ns #^{:doc "Pass remote calls and responses between lisp systems using the swank-rpc protocol."
:author "Terje Norderhaug <terje@in-progress.com>"}
swank.rpc
(:use (swank util)
(swank.util io))
(:import (java.io Writer Reader PushbackReader StringReader)))
;; ERROR HANDLING
(def swank-protocol-error (Exception. "Swank protocol error."))
;; LOGGING
(def log-events false)
(def log-output nil)
(defn log-event [format-string & args]
(when log-events
(.write (or log-output *out*) (apply format format-string args))
(.flush (or log-output *out*))
nil))
;; INPUT
(defn- read-form
"Read a form that conforms to the swank rpc protocol"
([#^Reader rdr]
(let [c (.read rdr)]
(condp = (char c)
\" (let [sb (StringBuilder.)]
(loop []
(let [c (.read rdr)]
(if (= c -1)
(throw (java.io.EOFException. "Incomplete reading of quoted string."))
(condp = (char c)
\" (str sb)
\\ (do (.append sb (char (.read rdr)))
(recur))
(do (.append sb (char c))
(recur)))))))
\( (loop [result []]
(let [form (read-form rdr)]
(let [c (.read rdr)]
(if (= c -1)
(throw (java.io.EOFException. "Incomplete reading of list."))
(condp = (char c)
\) (sequence (conj result form))
\space (recur (conj result form)))))))
\' (list 'quote (read-form rdr))
(let [sb (StringBuilder.)]
(loop [c c]
(if (not= c -1)
(condp = (char c)
\\ (do (.append sb (char (.read rdr)))
(recur (.read rdr)))
\space (.unread rdr c)
\) (.unread rdr c)
(do (.append sb (char c))
(recur (.read rdr))))))
(let [str (str sb)]
(cond
(. Character isDigit c) (Integer/parseInt str)
(= "nil" str) nil
(= "t" str) true
:else (symbol str))))))))
(defn- read-packet
([#^Reader reader]
(let [len (Integer/parseInt (read-chars reader 6 swank-protocol-error) 16)]
(read-chars reader len swank-protocol-error))))
(defn decode-message
"Read an rpc message encoded using the swank rpc protocol."
([#^Reader rdr]
(let [packet (read-packet rdr)]
(log-event "READ: %s\n" packet)
(try
(with-open [rdr (PushbackReader. (StringReader. packet))]
(read-form rdr))
(catch Exception e
(list :reader-error packet e))))))
; (with-open [rdr (StringReader. "00001f(swank:a 123 (%b% (t nil) \"c\"))")] (decode-message rdr))
;; OUTPUT
(defmulti print-object (fn [x writer] (type x)))
(defmethod print-object :default [o, #^Writer w]
(print-method o w))
(defmethod print-object Boolean [o, #^Writer w]
(.write w (if o "t" "nil")))
(defmethod print-object String [#^String s, #^Writer w]
(let [char-escape-string {\" "\\\""
\\ "\\\\"}]
(do (.append w \")
(dotimes [n (count s)]
(let [c (.charAt s n)
e (char-escape-string c)]
(if e (.write w e) (.append w c))))
(.append w \"))
nil))
(defmethod print-object clojure.lang.ISeq [o, #^Writer w]
(.write w "(")
(print-object (first o) w)
(doseq [item (rest o)]
(.write w " ")
(print-object item w))
(.write w ")"))
(defn- write-form
([#^Writer writer message]
(print-object message writer)))
(defn- write-packet
([#^Writer writer str]
(let [len (.length str)]
(doto writer
(.write (format "%06x" len))
(.write str)
(.flush)))))
(defn encode-message
"Write an rpc message encoded using the swank rpc protocol."
([#^Writer writer message]
(let [str (with-out-str
(write-form *out* message)) ]
(log-event "WRITE: %s\n" str)
(write-packet writer str))))
; (with-out-str (encode-message *out* "hello"))
; (with-out-str (encode-message *out* '(a 123 (swank:b (true false) "c"))))
;; DISPATCH
(defonce rpc-fn-map {})
(defn register-dispatch
([name fn]
(register-dispatch name fn #'rpc-fn-map))
([name fn fn-map]
(alter-var-root fn-map assoc name fn)))
(defn dispatch-message
([message fn-map]
(let [operation (first message)
operands (rest message)
fn (fn-map operation)]
(assert fn)
(apply fn operands)))
([message]
(dispatch-message message rpc-fn-map)))
|
