Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 108 lines (96 sloc) 4.852 kB
4e3317c @cemerick split handlers namespace into separate topical middleware namespaces
cemerick authored
1
2 (ns ^{:author "Chas Emerick"}
3 clojure.tools.nrepl.middleware.interruptible-eval
4 (:require [clojure.tools.nrepl.transport :as t]
5 clojure.main)
6 (:use [clojure.tools.nrepl.misc :only (response-for returning)])
7 (:import clojure.lang.LineNumberingPushbackReader
8 (java.io StringReader Writer)
9 (java.util.concurrent ArrayBlockingQueue TimeUnit)))
10
11 (def ^{:dynamic true
12 :doc "The message currently being evaluated."}
13 *msg* nil)
14
15 (defn evaluate
16 "Evaluates some code within the dynamic context defined by a map of `bindings`,
17 as per `clojure.core/get-thread-bindings`.
18
19 Uses `clojure.main/repl` to drive the evaluation of :code in a second
20 map argument (either a string or a seq of forms to be evaluated), which may
21 also optionally specify a :ns (resolved via `find-ns`). The map MUST
22 contain a Transport implementation in :transport; expression results and errors
23 will be sent via that Transport.
24
25 Returns the dynamic scope that remains after evaluating all expressions
26 in :code.
27
28 It is assumed that `bindings` already contains useful/appropriate entries
29 for all vars indicated by `clojure.main/with-bindings`."
30 [bindings {:keys [code ns transport] :as msg}]
31 (let [bindings (atom (merge bindings (when ns {#'*ns* (-> ns symbol find-ns)})))]
32 (try
33 (clojure.main/repl
34 :init (fn [] (push-thread-bindings @bindings))
35 :read (if (string? code)
36 (let [reader (LineNumberingPushbackReader. (StringReader. code))]
37 #(read reader false %2))
38 (let [q (java.util.concurrent.ArrayBlockingQueue. (count code) false code)]
39 #(or (.poll q 0 java.util.concurrent.TimeUnit/MILLISECONDS) %2)))
40 :prompt (fn [])
41 :need-prompt (constantly false)
42 ; TODO pretty-print?
43 :print (fn [v]
44 (reset! bindings (assoc (get-thread-bindings)
45 #'*3 *2
46 #'*2 *1
47 #'*1 v))
48 (t/send transport (response-for msg
49 {:value v
50 :ns (-> *ns* ns-name str)})))
51 ; TODO customizable exception prints
52 :caught (fn [e]
53 (let [root-ex (#'clojure.main/root-cause e)]
54 (when-not (instance? ThreadDeath root-ex)
55 (reset! bindings (assoc (get-thread-bindings) #'*e e))
56 (t/send transport (response-for msg {:status :eval-error
57 :ex (-> e class str)
58 :root-ex (-> root-ex class str)}))
59 (clojure.main/repl-caught e)))))
60 @bindings
61 (finally
62 (pop-thread-bindings)
63 (.flush ^Writer (@bindings #'*out*))
64 (.flush ^Writer (@bindings #'*err*))))))
65
66 #_(defn- pool-size [] (.getPoolSize clojure.lang.Agent/soloExecutor))
67
68
69 (defn interruptible-eval
70 "Evaluation middleware that supports interrupts. Returns a handler that supports
71 \"eval\" and \"interrupt\" :op-erations that delegates to the given handler
72 otherwise."
73 [h]
74 (fn [{:keys [op session interrupt-id id transport] :as msg}]
75 (case op
76 "eval"
77 (if-not (:code msg)
78 (t/send transport (response-for msg :status #{:error :no-code}))
79 (send-off session
80 (fn [bindings]
81 (alter-meta! session assoc
82 :thread (Thread/currentThread)
83 :eval-msg msg)
84 (binding [*msg* msg]
85 (returning (dissoc (evaluate bindings msg) #'*msg* #'*agent*)
86 (t/send transport (response-for msg :status :done))
87 (alter-meta! session dissoc :thread :eval-msg))))))
88
89 "interrupt"
90 ; interrupts are inherently racy; we'll check the agent's :eval-msg's :id and
91 ; bail if it's different than the one provided, but it's possible for
92 ; that message's eval to finish and another to start before we send
93 ; the interrupt / .stop.
94 (let [{:keys [id eval-msg ^Thread thread]} (meta session)]
95 (if (or (not interrupt-id)
96 (= interrupt-id (:id eval-msg)))
97 (if-not thread
98 (t/send transport (response-for msg :status #{:done :session-idle}))
99 (do
100 (.stop thread)
101 (t/send transport {:status #{:interrupted}
102 :id (:id eval-msg)
103 :session id})
104 (t/send transport (response-for msg :status #{:done}))))
105 (t/send transport (response-for msg :status #{:error :interrupt-id-mismatch :done}))))
106
107 (h msg))))
Something went wrong with that request. Please try again.