160 lines
4.7 KiB
Clojure
160 lines
4.7 KiB
Clojure
;;; 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)))
|