Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
77 lines (71 sloc) 3.33 KB
;;; (c) 2013-2015 Vsevolod Dyomkin
(in-package #:should-test)
(named-readtables:in-readtable rutils-readtable)
(defparameter *xml-output* *standard-output*)
(defun xml-escape (value)
(macrolet ((replace-all (text &rest from-to-pairs)
(if (endp from-to-pairs)
,(caar from-to-pairs)
(replace-all ,text ,@(cdr from-to-pairs))
,(cdar from-to-pairs)))))
(let ((value (princ-to-string value)))
(replace-all value
("<" . "&lt;")
(">" . "&gt;")
("'" . "&#39;")
("\"" . "&quot;")
("&" . "&amp;")))))
(defmacro xml (tag &rest attrs-&-body)
`(progn (write-string ,(fmt "<~(~A~)" tag) *xml-output*)
,@(loop :for (attr val) :on (butlast attrs-&-body) :by #'cddr :collect
`(when ,val
(format *xml-output* ,(fmt " ~(~A~)=\"~~A\"" attr)
(xml-escape ,val))))
,(if (oddp (length attrs-&-body))
`(progn (write-char #\> *xml-output*)
(when-it ,(last1 attrs-&-body)
(write-string (xml-escape it) *xml-output*))
(write-string ,(fmt "</~A>" tag) *xml-output*))
`(write-string " />" *xml-output*))))
(defun test-for-xunit (out &rest args &key id (package *package*) test)
"Like TEST but writes xunit-style XML test report to OUT."
(let ((*xml-output* out)
(start-ts (local-time:now))
(*test-output* (make-string-output-stream))
(*error-output* (make-string-output-stream)))
(mv-bind (success? failures errors) (apply 'test args)
(let ((tests (when test (list test)))
(now (local-time:now)))
(unless tests
(do-symbols (sym package)
(when-it (and (eql (symbol-package sym) (find-package package))
(get sym 'test))
(push it tests)))
(reversef tests))
(unless id
(write-line "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>" *xml-output*))
(xml :testsuite
:tests (length tests)
:failures (if failures (hash-table-count failures) 0)
:errors (if errors (hash-table-count errors) 0)
:hostname (osicat-posix:gethostname)
:name (fmt "~A~@[:~A~]" package test)
:time (coerce (* (local-time:timestamp-difference now start-ts)
:timestamp (slice (local-time:to-rfc3339-timestring now)
0 19) ; till seconds
(xml :properties nil)
(dolist (test tests)
(let ((failure (when failures (get# test failures)))
(error (when errors (get# test errors))))
(xml :testcase :classname (package-name package)
:name test :time "0"
(failure (xml :failure :type "failure" failure))
(error (xml :error :type "error" error))))))
(xml :system-out (get-output-stream-string *test-output*))
(xml :system-err (get-output-stream-string *error-output*))))))))