1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/clojure/test/junit.clj	Sat Aug 21 06:25:44 2010 -0400
     1.3 @@ -0,0 +1,194 @@
     1.4 +;   Copyright (c) Rich Hickey. All rights reserved.
     1.5 +;   The use and distribution terms for this software are covered by the
     1.6 +;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
     1.7 +;   which can be found in the file epl-v10.html at the root of this distribution.
     1.8 +;   By using this software in any fashion, you are agreeing to be bound by
     1.9 +;   the terms of this license.
    1.10 +;   You must not remove this notice, or any other, from this software.
    1.11 +
    1.12 +;; test/junit.clj: Extension to clojure.test for JUnit-compatible XML output
    1.13 +
    1.14 +;; by Jason Sankey
    1.15 +;; June 2009
    1.16 +
    1.17 +;; DOCUMENTATION
    1.18 +;;
    1.19 +
    1.20 +(ns ^{:doc "clojure.test extension for JUnit-compatible XML output.
    1.21 +
    1.22 +  JUnit (http://junit.org/) is the most popular unit-testing library
    1.23 +  for Java.  As such, tool support for JUnit output formats is
    1.24 +  common.  By producing compatible output from tests, this tool
    1.25 +  support can be exploited.
    1.26 +
    1.27 +  To use, wrap any calls to clojure.test/run-tests in the
    1.28 +  with-junit-output macro, like this:
    1.29 +
    1.30 +    (use 'clojure.test)
    1.31 +    (use 'clojure.test.junit)
    1.32 +
    1.33 +    (with-junit-output
    1.34 +      (run-tests 'my.cool.library))
    1.35 +
    1.36 +  To write the output to a file, rebind clojure.test/*test-out* to
    1.37 +  your own PrintWriter (perhaps opened using
    1.38 +  clojure.java.io/writer)."
    1.39 +  :author "Jason Sankey"}
    1.40 +  clojure.test.junit
    1.41 +  (:require [clojure.stacktrace :as stack]
    1.42 +            [clojure.test :as t]))
    1.43 +
    1.44 +;; copied from clojure.contrib.lazy-xml
    1.45 +(def ^{:private true}
    1.46 +     escape-xml-map
    1.47 +     (zipmap "'<>\"&" (map #(str \& % \;) '[apos lt gt quot amp])))
    1.48 +(defn- escape-xml [text]
    1.49 +  (apply str (map #(escape-xml-map % %) text)))
    1.50 +
    1.51 +(def *var-context*)
    1.52 +(def *depth*)
    1.53 +
    1.54 +(defn indent
    1.55 +  []
    1.56 +  (dotimes [n (* *depth* 4)] (print " ")))
    1.57 +
    1.58 +(defn start-element
    1.59 +  [tag pretty & [attrs]]
    1.60 +  (if pretty (indent))
    1.61 +  (print (str "<" tag))
    1.62 +  (if (seq attrs)
    1.63 +    (doseq [[key value] attrs]
    1.64 +      (print (str " " (name key) "=\"" (escape-xml value) "\""))))
    1.65 +  (print ">")
    1.66 +  (if pretty (println))
    1.67 +  (set! *depth* (inc *depth*)))
    1.68 +
    1.69 +(defn element-content
    1.70 +  [content]
    1.71 +  (print (escape-xml content)))
    1.72 +
    1.73 +(defn finish-element
    1.74 +  [tag pretty]
    1.75 +  (set! *depth* (dec *depth*))
    1.76 +  (if pretty (indent))
    1.77 +  (print (str "</" tag ">"))
    1.78 +  (if pretty (println)))
    1.79 +
    1.80 +(defn test-name
    1.81 +  [vars]
    1.82 +  (apply str (interpose "."
    1.83 +                        (reverse (map #(:name (meta %)) vars)))))
    1.84 +
    1.85 +(defn package-class
    1.86 +  [name]
    1.87 +  (let [i (.lastIndexOf name ".")]
    1.88 +    (if (< i 0)
    1.89 +      [nil name]
    1.90 +      [(.substring name 0 i) (.substring name (+ i 1))])))
    1.91 +
    1.92 +(defn start-case
    1.93 +  [name classname]
    1.94 +  (start-element 'testcase true {:name name :classname classname}))
    1.95 +
    1.96 +(defn finish-case
    1.97 +  []
    1.98 +  (finish-element 'testcase true))
    1.99 +
   1.100 +(defn suite-attrs
   1.101 +  [package classname]
   1.102 +  (let [attrs {:name classname}]
   1.103 +    (if package
   1.104 +      (assoc attrs :package package)
   1.105 +      attrs)))
   1.106 +
   1.107 +(defn start-suite
   1.108 +  [name]
   1.109 +  (let [[package classname] (package-class name)]
   1.110 +    (start-element 'testsuite true (suite-attrs package classname))))
   1.111 +
   1.112 +(defn finish-suite
   1.113 +  []
   1.114 +  (finish-element 'testsuite true))
   1.115 +
   1.116 +(defn message-el
   1.117 +  [tag message expected-str actual-str]
   1.118 +  (indent)
   1.119 +  (start-element tag false (if message {:message message} {}))
   1.120 +  (element-content
   1.121 +   (let [[file line] (t/file-position 5)
   1.122 +         detail (apply str (interpose
   1.123 +                            "\n"
   1.124 +                            [(str "expected: " expected-str)
   1.125 +                             (str "  actual: " actual-str)
   1.126 +                             (str "      at: " file ":" line)]))]
   1.127 +     (if message (str message "\n" detail) detail)))
   1.128 +  (finish-element tag false)
   1.129 +  (println))
   1.130 +
   1.131 +(defn failure-el
   1.132 +  [message expected actual]
   1.133 +  (message-el 'failure message (pr-str expected) (pr-str actual)))
   1.134 +
   1.135 +(defn error-el
   1.136 +  [message expected actual]
   1.137 +  (message-el 'error
   1.138 +              message
   1.139 +              (pr-str expected)
   1.140 +              (if (instance? Throwable actual)
   1.141 +                (with-out-str (stack/print-cause-trace actual t/*stack-trace-depth*))
   1.142 +                (prn actual))))
   1.143 +
   1.144 +;; This multimethod will override test-is/report
   1.145 +(defmulti junit-report :type)
   1.146 +
   1.147 +(defmethod junit-report :begin-test-ns [m]
   1.148 +  (t/with-test-out
   1.149 +   (start-suite (name (ns-name (:ns m))))))
   1.150 +
   1.151 +(defmethod junit-report :end-test-ns [_]
   1.152 +  (t/with-test-out
   1.153 +   (finish-suite)))
   1.154 +
   1.155 +(defmethod junit-report :begin-test-var [m]
   1.156 +  (t/with-test-out
   1.157 +   (let [var (:var m)]
   1.158 +     (binding [*var-context* (conj *var-context* var)]
   1.159 +       (start-case (test-name *var-context*) (name (ns-name (:ns (meta var)))))))))
   1.160 +
   1.161 +(defmethod junit-report :end-test-var [m]
   1.162 +  (t/with-test-out
   1.163 +   (finish-case)))
   1.164 +
   1.165 +(defmethod junit-report :pass [m]
   1.166 +  (t/with-test-out
   1.167 +   (t/inc-report-counter :pass)))
   1.168 +
   1.169 +(defmethod junit-report :fail [m]
   1.170 +  (t/with-test-out
   1.171 +   (t/inc-report-counter :fail)
   1.172 +   (failure-el (:message m)
   1.173 +               (:expected m)
   1.174 +               (:actual m))))
   1.175 +
   1.176 +(defmethod junit-report :error [m]
   1.177 +  (t/with-test-out
   1.178 +   (t/inc-report-counter :error)
   1.179 +   (error-el (:message m)
   1.180 +             (:expected m)
   1.181 +             (:actual m))))
   1.182 +
   1.183 +(defmethod junit-report :default [_])
   1.184 +
   1.185 +(defmacro with-junit-output
   1.186 +  "Execute body with modified test-is reporting functions that write
   1.187 +  JUnit-compatible XML output."
   1.188 +  {:added "1.1"}
   1.189 +  [& body]
   1.190 +  `(binding [t/report junit-report
   1.191 +             *var-context* (list)
   1.192 +             *depth* 1]
   1.193 +     (println "<?xml version=\"1.0\" encoding=\"UTF-8\"?>")
   1.194 +     (println "<testsuites>")
   1.195 +     (let [result# ~@body]
   1.196 +       (println "</testsuites>")
   1.197 +       result#)))