|
rlm@10
|
1 ;; Copyright (c) Stephen C. Gilardi. All rights reserved. The use and
|
|
rlm@10
|
2 ;; distribution terms for this software are covered by the Eclipse Public
|
|
rlm@10
|
3 ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can
|
|
rlm@10
|
4 ;; be found in the file epl-v10.html at the root of this distribution. By
|
|
rlm@10
|
5 ;; using this software in any fashion, you are agreeing to be bound by the
|
|
rlm@10
|
6 ;; terms of this license. You must not remove this notice, or any other,
|
|
rlm@10
|
7 ;; from this software.
|
|
rlm@10
|
8 ;;
|
|
rlm@10
|
9 ;; condition.clj
|
|
rlm@10
|
10 ;;
|
|
rlm@10
|
11 ;; scgilardi (gmail)
|
|
rlm@10
|
12 ;; Created 09 June 2009
|
|
rlm@10
|
13
|
|
rlm@10
|
14 (ns ^{:author "Stephen C. Gilardi"
|
|
rlm@10
|
15 :doc "Flexible raising and handling of conditions:
|
|
rlm@10
|
16
|
|
rlm@10
|
17 Functions:
|
|
rlm@10
|
18
|
|
rlm@10
|
19 raise: raises a condition
|
|
rlm@10
|
20 handler-case: dispatches raised conditions to appropriate handlers
|
|
rlm@10
|
21 print-stack-trace: prints abbreviated or full condition stack traces
|
|
rlm@10
|
22
|
|
rlm@10
|
23 Data:
|
|
rlm@10
|
24
|
|
rlm@10
|
25 A condition is a map containing values for these keys:
|
|
rlm@10
|
26
|
|
rlm@10
|
27 - :type, a condition type specifier, typically a keyword
|
|
rlm@10
|
28 - :stack-trace, a stack trace to the site of the raise
|
|
rlm@10
|
29 - :message, a human-readable message (optional)
|
|
rlm@10
|
30 - :cause, a wrapped exception or condition (optional)
|
|
rlm@10
|
31 - other keys given as arguments to raise (optional)
|
|
rlm@10
|
32
|
|
rlm@10
|
33 Note: requires AOT compilation.
|
|
rlm@10
|
34
|
|
rlm@10
|
35 Based on an idea from Chouser:
|
|
rlm@10
|
36 http://groups.google.com/group/clojure/browse_frm/thread/da1285c538f22bb5"}
|
|
rlm@10
|
37 clojure.contrib.condition
|
|
rlm@10
|
38 (:require clojure.contrib.condition.Condition)
|
|
rlm@10
|
39 (:import clojure.contrib.condition.Condition
|
|
rlm@10
|
40 clojure.lang.IPersistentMap)
|
|
rlm@10
|
41 (:use (clojure.contrib
|
|
rlm@10
|
42 [def :only (defvar)]
|
|
rlm@10
|
43 [seq :only (separate)])))
|
|
rlm@10
|
44
|
|
rlm@10
|
45 (defvar *condition*
|
|
rlm@10
|
46 "While a handler is running, bound to the condition being handled")
|
|
rlm@10
|
47
|
|
rlm@10
|
48 (defvar *selector*
|
|
rlm@10
|
49 "While a handler is running, bound to the selector returned by the
|
|
rlm@10
|
50 handler-case dispatch-fn for *condition*")
|
|
rlm@10
|
51
|
|
rlm@10
|
52 (defvar *condition-object*
|
|
rlm@10
|
53 "While a handler is running, bound to the Condition object whose metadata
|
|
rlm@10
|
54 is the condition")
|
|
rlm@10
|
55
|
|
rlm@10
|
56 (defvar *full-stack-traces* false
|
|
rlm@10
|
57 "Bind to true to include clojure.{core,lang,main} frames in stack
|
|
rlm@10
|
58 traces")
|
|
rlm@10
|
59
|
|
rlm@10
|
60 (defmacro raise
|
|
rlm@10
|
61 "Raises a condition. With no arguments, re-raises the current condition.
|
|
rlm@10
|
62 With one argument (a map), raises the argument. With two or more
|
|
rlm@10
|
63 arguments, raises a map with keys and values from the arguments."
|
|
rlm@10
|
64 ([]
|
|
rlm@10
|
65 `(throw *condition-object*))
|
|
rlm@10
|
66 ([m]
|
|
rlm@10
|
67 `(throw (Condition. ~m)))
|
|
rlm@10
|
68 ([key val & keyvals]
|
|
rlm@10
|
69 `(raise (hash-map ~key ~val ~@keyvals))))
|
|
rlm@10
|
70
|
|
rlm@10
|
71 (defmacro handler-case
|
|
rlm@10
|
72 "Executes body in a context where raised conditions can be handled.
|
|
rlm@10
|
73
|
|
rlm@10
|
74 dispatch-fn accepts a raised condition (a map) and returns a selector
|
|
rlm@10
|
75 used to choose a handler. Commonly, dispatch-fn will be :type to dispatch
|
|
rlm@10
|
76 on the condition's :type value.
|
|
rlm@10
|
77
|
|
rlm@10
|
78 Handlers are forms within body:
|
|
rlm@10
|
79
|
|
rlm@10
|
80 (handle key
|
|
rlm@10
|
81 ...)
|
|
rlm@10
|
82
|
|
rlm@10
|
83 If a condition is raised, executes the body of the first handler whose
|
|
rlm@10
|
84 key satisfies (isa? selector key). If no handlers match, re-raises the
|
|
rlm@10
|
85 condition.
|
|
rlm@10
|
86
|
|
rlm@10
|
87 While a handler is running, *condition* is bound to the condition being
|
|
rlm@10
|
88 handled and *selector* is bound to to the value returned by dispatch-fn
|
|
rlm@10
|
89 that matched the handler's key."
|
|
rlm@10
|
90 [dispatch-fn & body]
|
|
rlm@10
|
91 (let [[handlers code]
|
|
rlm@10
|
92 (separate #(and (list? %) (= 'handle (first %))) body)]
|
|
rlm@10
|
93 `(try
|
|
rlm@10
|
94 ~@code
|
|
rlm@10
|
95 (catch Condition c#
|
|
rlm@10
|
96 (binding [*condition-object* c#
|
|
rlm@10
|
97 *condition* (meta c#)
|
|
rlm@10
|
98 *selector* (~dispatch-fn (meta c#))]
|
|
rlm@10
|
99 (cond
|
|
rlm@10
|
100 ~@(mapcat
|
|
rlm@10
|
101 (fn [[_ key & body]]
|
|
rlm@10
|
102 `[(isa? *selector* ~key) (do ~@body)])
|
|
rlm@10
|
103 handlers)
|
|
rlm@10
|
104 :else (raise)))))))
|
|
rlm@10
|
105
|
|
rlm@10
|
106 (defmulti stack-trace-info
|
|
rlm@10
|
107 "Returns header, stack-trace, and cause info from conditions and
|
|
rlm@10
|
108 Throwables"
|
|
rlm@10
|
109 class)
|
|
rlm@10
|
110
|
|
rlm@10
|
111 (defmethod stack-trace-info IPersistentMap
|
|
rlm@10
|
112 [condition]
|
|
rlm@10
|
113 [(format "condition: %s, %s" (:type condition)
|
|
rlm@10
|
114 (dissoc condition :type :stack-trace :cause))
|
|
rlm@10
|
115 (:stack-trace condition)
|
|
rlm@10
|
116 (:cause condition)])
|
|
rlm@10
|
117
|
|
rlm@10
|
118 (defmethod stack-trace-info Condition
|
|
rlm@10
|
119 [condition]
|
|
rlm@10
|
120 (stack-trace-info (meta condition)))
|
|
rlm@10
|
121
|
|
rlm@10
|
122 (defmethod stack-trace-info Throwable
|
|
rlm@10
|
123 [throwable]
|
|
rlm@10
|
124 [(str throwable)
|
|
rlm@10
|
125 (.getStackTrace throwable)
|
|
rlm@10
|
126 (.getCause throwable)])
|
|
rlm@10
|
127
|
|
rlm@10
|
128 (defn print-stack-trace
|
|
rlm@10
|
129 "Prints a stack trace for a condition or Throwable. Skips frames for
|
|
rlm@10
|
130 classes in clojure.{core,lang,main} unless the *full-stack-traces* is
|
|
rlm@10
|
131 bound to logical true"
|
|
rlm@10
|
132 [x]
|
|
rlm@10
|
133 (let [[header frames cause] (stack-trace-info x)]
|
|
rlm@10
|
134 (printf "%s\n" header)
|
|
rlm@10
|
135 (doseq [frame frames]
|
|
rlm@10
|
136 (let [classname (.getClassName frame)]
|
|
rlm@10
|
137 (if (or *full-stack-traces*
|
|
rlm@10
|
138 (not (re-matches
|
|
rlm@10
|
139 #"clojure.(?:core|lang|main).*" classname)))
|
|
rlm@10
|
140 (printf " at %s/%s(%s:%s)\n"
|
|
rlm@10
|
141 classname
|
|
rlm@10
|
142 (.getMethodName frame)
|
|
rlm@10
|
143 (.getFileName frame)
|
|
rlm@10
|
144 (.getLineNumber frame)))))
|
|
rlm@10
|
145 (when cause
|
|
rlm@10
|
146 (printf "caused by: ")
|
|
rlm@10
|
147 (recur cause))))
|
