Mercurial > lasercutter

comparison src/clojure/test/junit.clj @ 10:ef7dbbd6452c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
added clojure source goodness
author Robert McIntyre <rlm@mit.edu>
date Sat, 21 Aug 2010 06:25:44 -0400
parents
children
comparison
equal deleted inserted replaced
9:35cf337adfcf 10:ef7dbbd6452c
1 ; Copyright (c) Rich Hickey. All rights reserved.
2 ; The use and distribution terms for this software are covered by the
3 ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
4 ; which can be found in the file epl-v10.html at the root of this distribution.
5 ; By using this software in any fashion, you are agreeing to be bound by
6 ; the terms of this license.
7 ; You must not remove this notice, or any other, from this software.
8
9 ;; test/junit.clj: Extension to clojure.test for JUnit-compatible XML output
10
11 ;; by Jason Sankey
12 ;; June 2009
13
14 ;; DOCUMENTATION
15 ;;
16
17 (ns ^{:doc "clojure.test extension for JUnit-compatible XML output.
18
19 JUnit (http://junit.org/) is the most popular unit-testing library
20 for Java. As such, tool support for JUnit output formats is
21 common. By producing compatible output from tests, this tool
22 support can be exploited.
23
24 To use, wrap any calls to clojure.test/run-tests in the
25 with-junit-output macro, like this:
26
27 (use 'clojure.test)
28 (use 'clojure.test.junit)
29
30 (with-junit-output
31 (run-tests 'my.cool.library))
32
33 To write the output to a file, rebind clojure.test/*test-out* to
34 your own PrintWriter (perhaps opened using
35 clojure.java.io/writer)."
36 :author "Jason Sankey"}
37 clojure.test.junit
38 (:require [clojure.stacktrace :as stack]
39 [clojure.test :as t]))
40
41 ;; copied from clojure.contrib.lazy-xml
42 (def ^{:private true}
43 escape-xml-map
44 (zipmap "'<>\"&" (map #(str \& % \;) '[apos lt gt quot amp])))
45 (defn- escape-xml [text]
46 (apply str (map #(escape-xml-map % %) text)))
47
48 (def *var-context*)
49 (def *depth*)
50
51 (defn indent
52 []
53 (dotimes [n (* *depth* 4)] (print " ")))
54
55 (defn start-element
56 [tag pretty & [attrs]]
57 (if pretty (indent))
58 (print (str "<" tag))
59 (if (seq attrs)
60 (doseq [[key value] attrs]
61 (print (str " " (name key) "=\"" (escape-xml value) "\""))))
62 (print ">")
63 (if pretty (println))
64 (set! *depth* (inc *depth*)))
65
66 (defn element-content
67 [content]
68 (print (escape-xml content)))
69
70 (defn finish-element
71 [tag pretty]
72 (set! *depth* (dec *depth*))
73 (if pretty (indent))
74 (print (str "</" tag ">"))
75 (if pretty (println)))
76
77 (defn test-name
78 [vars]
79 (apply str (interpose "."
80 (reverse (map #(:name (meta %)) vars)))))
81
82 (defn package-class
83 [name]
84 (let [i (.lastIndexOf name ".")]
85 (if (< i 0)
86 [nil name]
87 [(.substring name 0 i) (.substring name (+ i 1))])))
88
89 (defn start-case
90 [name classname]
91 (start-element 'testcase true {:name name :classname classname}))
92
93 (defn finish-case
94 []
95 (finish-element 'testcase true))
96
97 (defn suite-attrs
98 [package classname]
99 (let [attrs {:name classname}]
100 (if package
101 (assoc attrs :package package)
102 attrs)))
103
104 (defn start-suite
105 [name]
106 (let [[package classname] (package-class name)]
107 (start-element 'testsuite true (suite-attrs package classname))))
108
109 (defn finish-suite
110 []
111 (finish-element 'testsuite true))
112
113 (defn message-el
114 [tag message expected-str actual-str]
115 (indent)
116 (start-element tag false (if message {:message message} {}))
117 (element-content
118 (let [[file line] (t/file-position 5)
119 detail (apply str (interpose
120 "\n"
121 [(str "expected: " expected-str)
122 (str " actual: " actual-str)
123 (str " at: " file ":" line)]))]
124 (if message (str message "\n" detail) detail)))
125 (finish-element tag false)
126 (println))
127
128 (defn failure-el
129 [message expected actual]
130 (message-el 'failure message (pr-str expected) (pr-str actual)))
131
132 (defn error-el
133 [message expected actual]
134 (message-el 'error
135 message
136 (pr-str expected)
137 (if (instance? Throwable actual)
138 (with-out-str (stack/print-cause-trace actual t/*stack-trace-depth*))
139 (prn actual))))
140
141 ;; This multimethod will override test-is/report
142 (defmulti junit-report :type)
143
144 (defmethod junit-report :begin-test-ns [m]
145 (t/with-test-out
146 (start-suite (name (ns-name (:ns m))))))
147
148 (defmethod junit-report :end-test-ns [_]
149 (t/with-test-out
150 (finish-suite)))
151
152 (defmethod junit-report :begin-test-var [m]
153 (t/with-test-out
154 (let [var (:var m)]
155 (binding [*var-context* (conj *var-context* var)]
156 (start-case (test-name *var-context*) (name (ns-name (:ns (meta var)))))))))
157
158 (defmethod junit-report :end-test-var [m]
159 (t/with-test-out
160 (finish-case)))
161
162 (defmethod junit-report :pass [m]
163 (t/with-test-out
164 (t/inc-report-counter :pass)))
165
166 (defmethod junit-report :fail [m]
167 (t/with-test-out
168 (t/inc-report-counter :fail)
169 (failure-el (:message m)
170 (:expected m)
171 (:actual m))))
172
173 (defmethod junit-report :error [m]
174 (t/with-test-out
175 (t/inc-report-counter :error)
176 (error-el (:message m)
177 (:expected m)
178 (:actual m))))
179
180 (defmethod junit-report :default [_])
181
182 (defmacro with-junit-output
183 "Execute body with modified test-is reporting functions that write
184 JUnit-compatible XML output."
185 {:added "1.1"}
186 [& body]
187 `(binding [t/report junit-report
188 *var-context* (list)
189 *depth* 1]
190 (println "<?xml version=\"1.0\" encoding=\"UTF-8\"?>")
191 (println "<testsuites>")
192 (let [result# ~@body]
193 (println "</testsuites>")
194 result#)))