518 lines
17 KiB
Clojure
518 lines
17 KiB
Clojure
(ns slingshot.slingshot-test
|
|
(:require [clojure.test :refer :all]
|
|
[slingshot.slingshot :refer :all]
|
|
[clojure.string :as str])
|
|
(:import java.util.concurrent.ExecutionException))
|
|
|
|
(defrecord exception-record [error-code duration-ms message])
|
|
(defrecord x-failure [message])
|
|
|
|
(def a-sphere ^{:type ::sphere} {:radius 3})
|
|
|
|
(def h1 (derive (make-hierarchy) ::square ::shape))
|
|
(def a-square ^{:type ::square} {:size 4})
|
|
|
|
(def exception-1 (Exception. "exceptional"))
|
|
(def exception-record-1 (exception-record. 6 1000 "pdf failure"))
|
|
|
|
(defn mult-func [x y]
|
|
(let [a 7 b 11]
|
|
(if (= x 3)
|
|
(* a b x y)
|
|
(throw+ (x-failure. "x isn't 3... really??")))))
|
|
|
|
(defmacro mega-try [body]
|
|
`(try+
|
|
~body
|
|
|
|
;; by class derived from Throwable
|
|
(catch IllegalArgumentException e#
|
|
[:class-iae e#])
|
|
(catch Exception e#
|
|
[:class-exception e#])
|
|
|
|
;; by java class generically
|
|
(catch String e#
|
|
[:class-string e#])
|
|
|
|
;; by clojure record type
|
|
;; BB test patch, exception-record != class?, so this expands into incorrect code
|
|
#_(catch exception-record e#
|
|
[:class-exception-record e#])
|
|
|
|
;; by key-value
|
|
(catch [:a-key 4] e#
|
|
[:key-yields-value e#])
|
|
|
|
;; by multiple-key-value
|
|
(catch [:key1 4 :key2 5] e#
|
|
[:keys-yield-values e#])
|
|
|
|
;; by key present
|
|
(catch (and (set? ~'%) (contains? ~'% :a-key)) e#
|
|
[:key-is-present e#])
|
|
|
|
;; by clojure type, with optional hierarchy
|
|
(catch (isa? (type ~'%) ::sphere) e#
|
|
[:type-sphere (type e#) e#])
|
|
(catch (isa? h1 (type ~'%) ::shape) e#
|
|
[:type-shape-in-h1 (type e#) e#])
|
|
|
|
;; by predicate
|
|
(catch nil? e#
|
|
[:pred-nil e#])
|
|
(catch keyword? e#
|
|
[:pred-keyword e#])
|
|
(catch symbol? e#
|
|
[:pred-symbol e#])
|
|
(catch map? e#
|
|
[:pred-map e# (meta e#)])))
|
|
|
|
(deftest test-try+
|
|
(testing "catch by class derived from Throwable"
|
|
(testing "treat throwables exactly as throw does, interop with try/throw"
|
|
(is (= [:class-exception exception-1]
|
|
(mega-try (throw+ exception-1))
|
|
(mega-try (throw exception-1))
|
|
(try (throw+ exception-1)
|
|
(catch Exception e [:class-exception e]))
|
|
(try (throw exception-1)
|
|
(catch Exception e [:class-exception e])))))
|
|
(testing "IllegalArgumentException thrown by clojure/core"
|
|
(is (= :class-iae (first (mega-try (str/replace "foo" 1 1)))))))
|
|
|
|
(testing "catch by java class generically"
|
|
(is (= [:class-string "fail"] (mega-try (throw+ "fail")))))
|
|
|
|
;; BB-TEST-PATCH: bb has different record internals
|
|
#_(testing "catch by clojure record type"
|
|
(is (= [:class-exception-record exception-record-1]
|
|
(mega-try (throw+ exception-record-1)))))
|
|
|
|
(testing "catch by key is present"
|
|
(is (= [:key-is-present #{:a-key}] (mega-try (throw+ #{:a-key})))))
|
|
|
|
(testing "catch by keys and values"
|
|
(is (= [:key-yields-value {:a-key 4}] (mega-try (throw+ {:a-key 4}))))
|
|
(is (= [:keys-yield-values {:key1 4 :key2 5}]
|
|
(mega-try (throw+ {:key1 4 :key2 5})))))
|
|
|
|
(testing "catch by clojure type with optional hierarchy"
|
|
(is (= [:type-sphere ::sphere a-sphere] (mega-try (throw+ a-sphere))))
|
|
(is (= [:type-shape-in-h1 ::square a-square] (mega-try (throw+ a-square)))))
|
|
|
|
(testing "catch by predicate"
|
|
(is (= [:pred-nil nil] (mega-try (throw+ nil))))
|
|
(is (= [:pred-keyword :awesome] (mega-try (throw+ :awesome))))
|
|
(is (= [:pred-symbol 'yuletide] (mega-try (throw+ 'yuletide))))
|
|
(is (= [:pred-map {:error-code 4} nil] (mega-try (throw+ {:error-code 4}))))
|
|
(testing "preservation of metadata"
|
|
(is (= [:pred-map {:error-code 4} {:severity 4}]
|
|
(mega-try (throw+ ^{:severity 4} {:error-code 4})))))))
|
|
|
|
(deftest test-clauses
|
|
(let [bumps (atom 0)
|
|
bump (fn [] (swap! bumps inc))]
|
|
(is (nil? (try+)))
|
|
(is (nil? (try+ (catch integer? i (inc i)))))
|
|
(is (nil? (try+ (finally (bump)))))
|
|
(is (nil? (try+ (catch integer? i (inc i)) (finally (bump)))))
|
|
(is (nil? (try+ (catch integer? i (inc i)) (catch map? m m)
|
|
(finally (bump)))))
|
|
|
|
(is (= 3 (try+ 3)))
|
|
(is (= 3 (try+ 3 (catch integer? i 4))))
|
|
(is (= 3 (try+ 3 (finally (bump)))))
|
|
(is (= 3 (try+ 3 (catch integer? i 4) (finally (bump)))))
|
|
(is (= 4 (try+ (throw+ 3) (catch integer? i (inc i)) (finally (bump)))))
|
|
(is (= 4 (try+ (throw+ 3) (catch integer? i (inc i)) (catch map? m m)
|
|
(finally (bump)))))
|
|
(is (= 4 (try+ (throw+ {:sel 4}) (catch integer? i (inc i))
|
|
(catch map? m (:sel m)) (finally (bump)))))
|
|
|
|
(is (= 4 (try+ 3 4)))
|
|
(is (= 4 (try+ 3 4 (catch integer? i 4))))
|
|
(is (= 4 (try+ 3 4 (finally (bump)))))
|
|
(is (= 4 (try+ 3 4 (catch integer? i 4) (finally (bump)))))
|
|
(is (= 5 (try+ (throw+ 4) 4 (catch integer? i (inc i)) (finally (bump)))))
|
|
(is (= 11 @bumps))))
|
|
|
|
(defn ax [] (throw+ 1))
|
|
(defn bx [] (try+ (ax) (catch integer? p (throw+ 2))))
|
|
(defn cx [] (try+ (bx) (catch integer? q (throw+ 3))))
|
|
(defn dx [] (try+ (cx) (catch integer? r (throw+ 4))))
|
|
(defn ex [] (try+ (dx) (catch integer? s (throw+ 5))))
|
|
(defn fx [] (try+ (ex) (catch integer? t (throw+ 6))))
|
|
(defn gx [] (try+ (fx) (catch integer? u (throw+ 7))))
|
|
(defn hx [] (try+ (gx) (catch integer? v (throw+ 8))))
|
|
(defn ix [] (try+ (hx) (catch integer? w &throw-context)))
|
|
|
|
(defn next-context [x]
|
|
(-> x :cause get-throw-context))
|
|
|
|
(deftest test-throw-context
|
|
(let [context (ix)
|
|
context1 (next-context context)
|
|
context2 (next-context context1)]
|
|
|
|
(is (= #{:object :message :cause :stack-trace :wrapper :throwable}
|
|
(set (keys context))
|
|
(set (keys context1))
|
|
(set (keys context2))))
|
|
(is (= 8 (-> context :object)))
|
|
(is (= 7 (-> context1 :object)))
|
|
(is (= 6 (-> context2 :object)))))
|
|
|
|
(defn e []
|
|
(try+
|
|
(throw (Exception. "uncaught"))
|
|
(catch integer? i i)))
|
|
|
|
(defn f []
|
|
(try+
|
|
(throw+ 3.2)
|
|
(catch integer? i i)))
|
|
|
|
|
|
(defn g []
|
|
(try+
|
|
(throw+ 3.2 "wasn't caught")
|
|
(catch integer? i i)))
|
|
|
|
(deftest test-uncaught
|
|
(is (thrown-with-msg? Exception #"^uncaught$" (e)))
|
|
(is (thrown-with-msg? Exception #"^throw\+: .*" (f)))
|
|
(is (thrown-with-msg? Exception #"wasn't caught" (g))))
|
|
|
|
(defn h []
|
|
(try+
|
|
(try+
|
|
(throw+ 0)
|
|
(catch zero? e
|
|
(throw+)))
|
|
(catch zero? e
|
|
:zero)))
|
|
|
|
(deftest test-rethrow
|
|
(is (= :zero (h))))
|
|
|
|
(defn i []
|
|
(try
|
|
(try+
|
|
(doall (map (fn [x] (throw+ (str x))) [1]))
|
|
(catch string? x
|
|
x))
|
|
(catch Throwable x)))
|
|
|
|
(defn j []
|
|
(try+
|
|
(let [fut (future (throw+ "whoops"))]
|
|
@fut)
|
|
(catch string? e
|
|
e)))
|
|
|
|
(deftest test-issue-5
|
|
(is (= "1" (i)))
|
|
(is (= "whoops" (j))))
|
|
|
|
(deftest test-unmacroed-pct
|
|
(is (= :was-eee (try+ (throw+ "eee")
|
|
(catch (= % "eee") _ :was-eee)
|
|
(catch string? _ :no!)))))
|
|
|
|
(deftest test-x-ray-vision
|
|
(let [[val wrapper] (try+
|
|
(try
|
|
(try
|
|
(try
|
|
(throw+ "x-ray!")
|
|
(catch Throwable x
|
|
(throw (RuntimeException. x))))
|
|
(catch Throwable x
|
|
(throw (ExecutionException. x))))
|
|
(catch Throwable x
|
|
(throw (RuntimeException. x))))
|
|
(catch string? x
|
|
[x (:throwable &throw-context)]))]
|
|
(is (= "x-ray!" val))
|
|
(is (= "x-ray!" (get-thrown-object wrapper)))))
|
|
|
|
(deftest test-catching-wrapper
|
|
(let [e (Exception.)]
|
|
(try
|
|
(try+
|
|
(throw e)
|
|
(catch Exception _
|
|
(throw+ :a "msg: %s" %)))
|
|
(is false)
|
|
(catch Exception s
|
|
(is (= "msg: :a" (.getMessage s)))
|
|
(is (= e (.getCause s)))))))
|
|
|
|
(deftest test-eval-object-once
|
|
(let [bumps (atom 0)
|
|
bump (fn [] (swap! bumps inc))]
|
|
(try+
|
|
(throw+ (bump) "this is it: %s %s %s" % % %)
|
|
(catch Object _))
|
|
(is (= @bumps 1))))
|
|
|
|
(deftest test-get-throw-context
|
|
(let [object (Object.)
|
|
exception1 (Exception.)
|
|
exception2 (Exception. "ex1" exception1)
|
|
t1 (try
|
|
(throw+ object)
|
|
(catch Throwable t t))
|
|
t2 (try
|
|
(throw+ exception2)
|
|
(catch Throwable t t))
|
|
t3 (try
|
|
(throw exception2)
|
|
(catch Throwable t t))]
|
|
(is (= #{:object :message :cause :stack-trace :wrapper
|
|
:throwable}
|
|
(-> t1 get-throw-context keys set)))
|
|
(is (= #{:object :message :cause :stack-trace :throwable}
|
|
(-> t2 get-throw-context keys set)))
|
|
(is (= #{:object :message :cause :stack-trace :throwable}
|
|
(-> t3 get-throw-context keys set)))
|
|
|
|
(is (identical? object (:object (get-throw-context t1))))
|
|
(is (identical? exception2 (:object (get-throw-context t2))))
|
|
(is (identical? exception2 (:object (get-throw-context t3))))
|
|
|
|
(is (identical? exception1 (:cause (get-throw-context t2))))
|
|
(is (identical? exception1 (:cause (get-throw-context t3))))
|
|
(is (= "ex1" (:message (get-throw-context t2))))
|
|
(is (= "ex1" (:message (get-throw-context t3))))))
|
|
|
|
(deftest test-get-thrown-object
|
|
(let [object (Object.)
|
|
exception (Exception.)
|
|
t1 (try
|
|
(throw+ object)
|
|
(catch Throwable t t))
|
|
t2 (try
|
|
(throw+ exception)
|
|
(catch Throwable t t))
|
|
t3 (try
|
|
(throw exception)
|
|
(catch Throwable t t))]
|
|
(is (identical? object (get-thrown-object t1)))
|
|
(is (identical? exception (get-thrown-object t2)))
|
|
(is (identical? exception (get-thrown-object t3)))))
|
|
|
|
(deftest test-wrapper-and-throwable
|
|
(let [context (try+
|
|
(try
|
|
(throw+ :afp "wrapper-0")
|
|
(catch Exception e
|
|
(throw (RuntimeException. "wrapper-1" e))))
|
|
(catch Object _
|
|
&throw-context))]
|
|
(is (= "wrapper-0" (.getMessage ^Throwable (:wrapper context))))
|
|
(is (= "wrapper-1" (.getMessage ^Throwable (:throwable context))))))
|
|
|
|
(deftest test-inline-predicate
|
|
(is (= :not-caught (try+
|
|
(throw+ {:foo true})
|
|
(catch #(-> % :foo (= false)) data
|
|
:caught)
|
|
(catch Object _
|
|
:not-caught)))))
|
|
|
|
(defn gen-body
|
|
[rec-sym throw?]
|
|
(let [body `(swap! ~rec-sym #(conj % :body))]
|
|
(if throw?
|
|
(list 'do body `(throw+ (Exception.)))
|
|
body)))
|
|
|
|
(defn gen-catch-clause
|
|
[rec-sym]
|
|
`(catch Exception e# (swap! ~rec-sym #(conj % :catch))))
|
|
|
|
(defn gen-else-clause
|
|
[rec-sym broken?]
|
|
(let [else-body `(swap! ~rec-sym #(conj % :else))]
|
|
(if broken?
|
|
(list 'else (list 'do else-body `(throw+ (Exception.))))
|
|
(list 'else else-body))))
|
|
|
|
(defn gen-finally-clause
|
|
[rec-sym]
|
|
`(finally (swap! ~rec-sym #(conj % :finally))))
|
|
|
|
(defn gen-try-else-form
|
|
"Generate variations of (try ... (else ...) ...) forms, which (when eval'd)
|
|
will return a vector describing the sequence in which things were evaluated,
|
|
e.g. [:body :catch :finally]"
|
|
[throw? catch? finally? broken-else?]
|
|
(let [rec-sym (gensym "rec")
|
|
body (gen-body rec-sym throw?)
|
|
catch-clause (if catch? (gen-catch-clause rec-sym))
|
|
else-clause (gen-else-clause rec-sym broken-else?)
|
|
finally-clause (if finally? (gen-finally-clause rec-sym))]
|
|
`(let [~rec-sym (atom [])]
|
|
(try+
|
|
~(remove nil? `(try+
|
|
~body
|
|
~catch-clause
|
|
~else-clause
|
|
~finally-clause))
|
|
(catch Object e#
|
|
;; if the inner try+ threw, report it as a :bang! in the return vec
|
|
(swap! ~rec-sym #(conj % :bang!))))
|
|
@~rec-sym)))
|
|
|
|
(deftest test-else
|
|
(doseq [throw? [true false]
|
|
catch? [true false]
|
|
broken-else? [true false]
|
|
finally? [true false]]
|
|
(testing (str "test-else: throw? " throw? " catch? " catch?
|
|
" broken-else? " broken-else? " finally? " finally?)
|
|
(let [try-else-form (gen-try-else-form throw? catch? finally? broken-else?)
|
|
actual (eval try-else-form)
|
|
expected (vec (remove nil?
|
|
[:body
|
|
(if (and throw? catch?) :catch)
|
|
(if (not throw?) :else)
|
|
(if finally? :finally)
|
|
;; expect an escaped exception when either:
|
|
;; a) the else clause runs, and throws
|
|
;; b) the body throws, and is not caught
|
|
(if (or (and (not throw?) broken-else?)
|
|
(and throw? (not catch?))) :bang!)]))]
|
|
(is (= actual expected))))))
|
|
|
|
(deftest test-reflection
|
|
(try+
|
|
nil
|
|
(catch Exception e
|
|
(.getMessage e))))
|
|
|
|
(deftest test-ex-info-compatibility
|
|
(let [data {:type :fail :reason :not-found}
|
|
message "oops"
|
|
wrapper (ex-info message data)
|
|
rte1 (RuntimeException. "one" wrapper)
|
|
rte2 (RuntimeException. "two" rte1)
|
|
direct (try+
|
|
(throw wrapper)
|
|
(catch [:type :fail] e
|
|
&throw-context)
|
|
(catch Object _
|
|
:whoops))
|
|
cause-chain (try+
|
|
(throw rte2)
|
|
(catch [:type :fail] e
|
|
&throw-context)
|
|
(catch Object _
|
|
:whoops))]
|
|
(is (= (:object direct) data))
|
|
(is (= (:object cause-chain) data))
|
|
(is (= (:message direct) message))
|
|
(is (= (:message cause-chain) message))
|
|
(is (= (:wrapper direct) wrapper))
|
|
(is (= (:wrapper cause-chain) wrapper))
|
|
(is (= (:throwable direct) wrapper))
|
|
(is (= (:throwable cause-chain) rte2))))
|
|
|
|
;; helpers for test-optional-cause
|
|
|
|
(defmacro caught-result [& body]
|
|
`(try+
|
|
~@body
|
|
(catch Object ~'o
|
|
[(:cause ~'&throw-context)
|
|
(:message ~'&throw-context)])))
|
|
|
|
(defmacro caught-result-from-catch [cause & body]
|
|
`(caught-result
|
|
(try+
|
|
(throw+ ~cause)
|
|
(catch Object ~'o
|
|
~@body))))
|
|
|
|
(deftest test-optional-cause
|
|
(let [imp (Exception. "I did it implicitly.")
|
|
exp (Exception. "I did it explicitly.")
|
|
def-msg "throw+: 1"
|
|
msg "message two %s"
|
|
fmt "aha! %s"
|
|
fmt-msg "aha! 1"
|
|
fmt2 "%s leading to %s"
|
|
fmt2-msg "1 leading to [1 1]"
|
|
|
|
;; throw from outside catch, no implicit cause
|
|
|
|
result1 (caught-result (throw+ 1))
|
|
result2 (caught-result (throw+ 1 msg))
|
|
result3 (caught-result (throw+ 1 fmt %))
|
|
result4 (caught-result (throw+ 1 fmt2 % [% %]))
|
|
|
|
result5 (caught-result (throw+ 1 nil))
|
|
result6 (caught-result (throw+ 1 nil msg))
|
|
result7 (caught-result (throw+ 1 nil fmt %))
|
|
result8 (caught-result (throw+ 1 nil fmt2 % [% %]))
|
|
|
|
result9 (caught-result (throw+ 1 exp))
|
|
result10 (caught-result (throw+ 1 exp msg))
|
|
result11 (caught-result (throw+ 1 exp fmt %))
|
|
result12 (caught-result (throw+ 1 exp fmt2 % [% %]))
|
|
|
|
;; throw from inside catch, implicit cause available
|
|
|
|
result13 (caught-result-from-catch imp (throw+))
|
|
|
|
result14 (caught-result-from-catch imp (throw+ 1))
|
|
result15 (caught-result-from-catch imp (throw+ 1 msg))
|
|
result16 (caught-result-from-catch imp (throw+ 1 fmt %))
|
|
result17 (caught-result-from-catch imp (throw+ 1 fmt2 % [% %]))
|
|
|
|
result18 (caught-result-from-catch imp (throw+ 1 nil))
|
|
result19 (caught-result-from-catch imp (throw+ 1 nil msg))
|
|
result20 (caught-result-from-catch imp (throw+ 1 nil fmt %))
|
|
result21 (caught-result-from-catch imp (throw+ 1 nil fmt2 % [% %]))
|
|
|
|
result22 (caught-result-from-catch imp (throw+ 1 exp))
|
|
result23 (caught-result-from-catch imp (throw+ 1 exp msg))
|
|
result24 (caught-result-from-catch imp (throw+ 1 exp fmt %))
|
|
result25 (caught-result-from-catch imp (throw+ 1 exp fmt2 % [% %]))]
|
|
|
|
(testing "outside catch"
|
|
(testing "implicit cause"
|
|
(is (= result1 [nil def-msg]))
|
|
(is (= result2 [nil msg]))
|
|
(is (= result3 [nil fmt-msg]))
|
|
(is (= result4 [nil fmt2-msg])))
|
|
(testing "erased cause"
|
|
(is (= result5 [nil def-msg]))
|
|
(is (= result6 [nil msg]))
|
|
(is (= result7 [nil fmt-msg]))
|
|
(is (= result8 [nil fmt2-msg])))
|
|
(testing "explicit cause"
|
|
(is (= result9 [exp def-msg]))
|
|
(is (= result10 [exp msg]))
|
|
(is (= result11 [exp fmt-msg]))
|
|
(is (= result12 [exp fmt2-msg]))))
|
|
(testing "inside catch"
|
|
(testing "rethrow"
|
|
(is (= result13 [nil "I did it implicitly."])))
|
|
(testing "implicit cause"
|
|
(is (= result14 [imp def-msg]))
|
|
(is (= result15 [imp msg]))
|
|
(is (= result16 [imp fmt-msg]))
|
|
(is (= result17 [imp fmt2-msg])))
|
|
(testing "erased cause"
|
|
(is (= result18 [nil def-msg]))
|
|
(is (= result19 [nil msg]))
|
|
(is (= result20 [nil fmt-msg]))
|
|
(is (= result21 [nil fmt2-msg])))
|
|
(testing "explicit cause"
|
|
(is (= result22 [exp def-msg]))
|
|
(is (= result23 [exp msg]))
|
|
(is (= result24 [exp fmt-msg]))
|
|
(is (= result25 [exp fmt2-msg]))))))
|