Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
198 lines (173 sloc) 5.92 KB
; Copyright (c) Rich Hickey, Stuart Halloway, and contributors.
; All rights reserved.
; The use and distribution terms for this software are covered by the
; Eclipse Public License 1.0 (
; which can be found in the file epl-v10.html at the root of this distribution.
; By using this software in any fashion, you are agreeing to be bound by
; the terms of this license.
; You must not remove this notice, or any other, from this software.
(ns clojure.test.generative.runner
[clojure.pprint :as pprint]
[ :as ns]
[ :as gen]
[clojure.test.generative :as tgen]))
(set! *warn-on-reflection* true)
(def ^:private config-mapping
(max 1 (dec (.availableProcessors (Runtime/getRuntime))))]
(defn- config
(fn [m [prop path coerce default]]
(let [val (System/getProperty prop)]
(if (seq val)
(assoc-in m path (coerce val))
(assoc-in m path default))))
(def ^:private ^java.util.Random rnd (java.util.Random. (System/currentTimeMillis)))
(defn- next-seed
(locking rnd
(.nextInt rnd)))
(defprotocol Testable
(get-tests [_]))
(extend-protocol Testable
(let [m (meta v)
arg-fns (::tgen/arg-fns m)
specs (::tgen/specs m)]
[{:test (-> (if-let [ns (.ns v)]
(str ns "/" (.sym v))
(.sym v))
:input-gen (fn []
(fn []
(into [] (map #(%) arg-fns)))))}]
(defn- find-vars-in-namespaces
[& nses]
(when nses
(reduce (fn [v ns] (into v (vals (ns-interns ns)))) [] nses)))
(defn- find-vars-in-dirs
[& dirs]
(let [nses (mapcat #(ns/find-namespaces-in-dir ( ^String %)) dirs)]
(doseq [ns nses] (require ns))
(apply find-vars-in-namespaces nses)))
(defn- run-one
"Run f (presumably for side effects) repeatedly on n threads,
until msec has passed or somebody throws an exception.
Returns as many status maps as seeds passed in."
[{:keys [test input-gen]} {:keys [msec seeds]}]
(let [f (eval test)
start (System/currentTimeMillis)
futs (mapv
(binding [gen/*rnd* (java.util.Random. %)]
(loop [iter 0
[input & more] (input-gen)]
(let [status {:iter iter :seed % :test test :input input}]
(if input
(let [failure (try
(apply f input)
(catch Throwable t
(assoc status :exception t) ))
now (System/currentTimeMillis)]
failure failure
(< now (+ start msec)) (recur (inc iter) more)
:else (select-keys status [:test :seed :iter])))
(assoc status :exhausted true)))))))
(map deref futs)))
(defn- failed?
"Does test result indicate a failure?"
(contains? result :exception))
(defn- run-n
"Run tests in parallel on nthreads, dividing msec equally between the tests.
Returns a list of maps of :iter, :seed"
[{:keys [nthreads msec]} tests]
(mapcat #(run-one %
{:msec (/ msec (count tests))
:seeds (repeatedly nthreads next-seed)})
(defn- prf
"Print and flush."
(print s) (flush))
(defn dir-tests
"Returns all tests in dirs"
(let [load (fn [s] (require s) s)]
(->> (mapcat #(ns/find-namespaces-in-dir ( ^String %)) dirs)
(map load)
(apply find-vars-in-namespaces)
(mapcat get-tests))))
(defn inputs
"For interactive use. Returns an infinite sequence of inputs for
a test."
((:input-gen test)))
(defn run
"Designed for interactive use. Prints results to *out* and throws
on first failure encountered."
[nthreads msec & test-containers]
(doseq [result (run-n {:nthreads nthreads
:msec msec}
(mapcat get-tests test-containers))]
(if (failed? result)
(throw (ex-info "Generative test failed" result))
(prn result))))
(defn run-suite
"Designed for test suite use."
[{:keys [nthreads msec progress]} tests]
(let [progress (or progress #(prf "."))
ret (reduce
(fn [{:keys [failures iters nresults]} result]
(when (:exception result)
(.printStackTrace ^Throwable (:exception result)))
(if (:exception result)
(prn result)
{:failures (+ failures (if (:exception result) 1 0))
:iters (+ iters (:iter result))
:nresults (+ nresults 1)})
{:failures 0 :iters 0 :nresults 0}
(run-n {:nthreads nthreads
:msec msec}
(-> ret
(assoc :tests (/ (:nresults ret) nthreads))
(dissoc :nresults))))
(defn -main
"Command line entry point. Calls System.exit!"
[& dirs]
(if (seq dirs)
(let [result (run-suite (config) (dir-tests dirs))]
(println "\n" result)
(System/exit (:failures result)))
(catch Throwable t
(.printStackTrace t)
(System/exit -1))
(println "Specify at least one directory with tests")
(System/exit -1))))
Something went wrong with that request. Please try again.