(in-package #:xlunit)
-(define-condition assertion-failed (simple-condition)
+(define-condition assertion-failed (simple-condition)
((message :initform nil :initarg :message :accessor message))
(:documentation "Base class for all test failures."))
(defmethod print-object ((obj assertion-failed) stream)
(print-unreadable-object (obj stream :type t :identity nil)
(apply #'format stream (simple-condition-format-control obj)
- (simple-condition-format-arguments obj))))
+ (simple-condition-format-arguments obj))))
(defun failure-message (message &optional format-str &rest args)
"Signal a test failure and exit the test."
(signal 'assertion-failed :message message :format-control format-str
- :format-arguments args))
+ :format-arguments args))
(defun failure (format-str &rest args)
"Signal a test failure and exit the test."
(defmacro assert-condition (condition form &optional message)
(let ((cond (gensym "COND-")))
`(handler-case
- (progn
- ,form
- (values))
+ (progn
+ ,form
+ (values))
(t (,cond)
- (when (and (typep ,cond 'serious-condition)
- (not (typep ,cond ,condition)))
- (failure-message
- ,message
- "Assert condition ~A, but signaled condition ~A"
- ,condition ,cond)))
+ (when (and (typep ,cond 'serious-condition)
+ (not (typep ,cond ,condition)))
+ (failure-message
+ ,message
+ "Assert condition ~A, but signaled condition ~A"
+ ,condition ,cond)))
(:no-error ()
- (failure-message ,message
- "Assert condition ~A, but no condition signaled"
- ,condition)))))
+ (failure-message ,message
+ "Assert condition ~A, but no condition signaled"
+ ,condition)))))
(defmacro assert-not-condition (condition form &optional message)
(let ((cond (gensym "COND-")))
`(handler-case
- (progn
- ,form
- (values))
+ (progn
+ ,form
+ (values))
(serious-condition (,cond)
- (unless (typep ,cond ,condition)
- (failure-message ,message "Assert not condition ~A"
- ,condition))))))
+ (unless (typep ,cond ,condition)
+ (failure-message ,message "Assert not condition ~A"
+ ,condition))))))
`(if ,test
(handler-case
,form
- ,@cases)
+ ,@cases)
,form))
(defmacro unwind-protect-if (test protected cleanup)
`(if ,test
(unwind-protect
- ,protected
- ,cleanup)
+ ,protected
+ ,cleanup)
(progn ,protected ,cleanup)))
(defmethod run-test ((test test-fixture)
- &key (result (make-instance 'test-result))
- (handle-errors t))
+ &key (result (make-instance 'test-result))
+ (handle-errors t))
"Perform the test represented by the given test-case or test-suite.
Returns a test-result object."
(incf (test-count result))
(with-slots (failures errors) result
(unwind-protect-if handle-errors
- (handler-case-if handle-errors
- (let ((res (progn (setup test)
- (funcall (test-fn test) test))))
- (when (typep res 'test-failure-condition)
- (push (make-test-failure test res) failures)))
- (test-failure-condition (failure)
- (push (make-test-failure test failure) failures))
- (error (err)
- (push (make-test-failure test err) errors)))
-
- (if handle-errors
- (handler-case
- (teardown test)
- (error (err)
- (push (make-test-failure test err) errors)))
- (teardown test))))
+ (handler-case-if handle-errors
+ (let ((res (progn (setup test)
+ (funcall (test-fn test) test))))
+ (when (typep res 'test-failure-condition)
+ (push (make-test-failure test res) failures)))
+ (test-failure-condition (failure)
+ (push (make-test-failure test failure) failures))
+ (error (err)
+ (push (make-test-failure test err) errors)))
+
+ (if handle-errors
+ (handler-case
+ (teardown test)
+ (error (err)
+ (push (make-test-failure test err) errors)))
+ (teardown test))))
result)
symbol or a lambda taking a single argument, the test-fixture
instance. DESCRIPTION is obviously what it says it is."
(let ((newtest (make-instance fixture
- :test-name (etypecase name
- (symbol
- (string-downcase (symbol-name name)))
- (string
- name))
- :test-fn
- (if(and (symbolp name) (null test-fn))
- name
- test-fn)
- :description description)))
+ :test-name (etypecase name
+ (symbol
+ (string-downcase (symbol-name name)))
+ (string
+ name))
+ :test-fn
+ (if(and (symbolp name) (null test-fn))
+ name
+ test-fn)
+ :description description)))
(when test-suite (add-test newtest test-suite))
newtest))
(defmethod end-test ((obj test-listener) tcase)
(declare (ignore tcase)))
-
+
(defpackage #:xlunit
(:use #:cl)
(:export
-
+
;; test-case.lisp
#:test-case
#:def-test-method
#:suite
#:test-suite
#:run-on-test-results
-
+
;; printer.lisp
#:summary
-
+
;; result.lisp
#:test-results
#:make-test-results
;----------------------------------------------------------------------
; method print-results
;----------------------------------------------------------------------
-
+
(defmethod print-results ((obj textui-test-runner) result seconds)
(print-header obj result seconds)
(print-defects obj (errors result) "error")
(print-defects obj (failures result) "failure")
(print-footer obj result)
(values))
-
+
(defmethod print-header ((obj textui-test-runner) result seconds)
(declare (ignore result))
(format (ostream obj) "~&Time: ~D~%~%" (coerce seconds 'float)))
-
+
(defmethod print-defects ((obj textui-test-runner) defects title)
(when defects
(let ((count (length defects)))
(if (= 1 count)
- (format (ostream obj) "~%There was 1 ~A:~%" title)
+ (format (ostream obj) "~%There was 1 ~A:~%" title)
(format (ostream obj) "~%There were ~D ~A:~%"
- count title))
+ count title))
(dotimes (i count)
- (let* ((defect (nth i defects))
- (condition (thrown-condition defect)))
- (format (ostream obj) "~A) ~A: "
- (1+ i) (name (failed-test defect)))
- (typecase condition
- (assertion-failed
- (apply #'format (ostream obj)
- (simple-condition-format-control condition)
- (simple-condition-format-arguments condition))
- (format (ostream obj) "~%")
- (when (message condition)
- (let ((spaces (+ 2 (length (format nil "~D" count)))))
- (dotimes (i spaces)
- (write-char #\space (ostream obj))))
- (format (ostream obj) "~A~%" (message condition))))
- (t
- (format (ostream obj) "~A~%" condition))))))))
+ (let* ((defect (nth i defects))
+ (condition (thrown-condition defect)))
+ (format (ostream obj) "~A) ~A: "
+ (1+ i) (name (failed-test defect)))
+ (typecase condition
+ (assertion-failed
+ (apply #'format (ostream obj)
+ (simple-condition-format-control condition)
+ (simple-condition-format-arguments condition))
+ (format (ostream obj) "~%")
+ (when (message condition)
+ (let ((spaces (+ 2 (length (format nil "~D" count)))))
+ (dotimes (i spaces)
+ (write-char #\space (ostream obj))))
+ (format (ostream obj) "~A~%" (message condition))))
+ (t
+ (format (ostream obj) "~A~%" condition))))))))
(defmethod print-footer ((obj textui-test-runner) result)
(defgeneric summary (result))
(defmethod summary ((result test-results))
(format nil "~D run, ~D erred, ~D failed"
- (run-tests result) (error-count result) (failure-count result)))
+ (run-tests result) (error-count result) (failure-count result)))
(defmethod start-test ((tcase test) (res test-results))
(incf (run-tests res))
(mapc (lambda (listener)
- (start-test listener tcase))
- (listeners res))
+ (start-test listener tcase))
+ (listeners res))
res)
(defmethod end-test ((tcase test) (res test-results))
(defclass test-failure ()
((failed-test :initarg :failed-test :reader failed-test)
(thrown-condition :initarg :thrown-condition
- :reader thrown-condition))
+ :reader thrown-condition))
(:documentation "Stored failures/errors in test-results slots"))
(defun make-test-failure (test condition)
(make-instance 'test-failure :failed-test test
- :thrown-condition condition))
+ :thrown-condition condition))
(defmethod is-failure ((failure test-failure))
"Returns T if a failure was a test-failure condition"
(defmethod print-object ((obj test-failure) stream)
(print-unreadable-object (obj stream :type t :identity nil)
(format stream "~A: " (failed-test obj))
- (apply #'format stream
- (simple-condition-format-control (thrown-condition obj))
- (simple-condition-format-arguments (thrown-condition obj)))))
+ (apply #'format stream
+ (simple-condition-format-control (thrown-condition obj))
+ (simple-condition-format-arguments (thrown-condition obj)))))
(defmethod was-successful ((result test-results))
"Returns T if a result has no failures or errors"
(defmethod add-error ((ob test-results) (tcase test-case) condition)
(push (make-test-failure tcase condition) (errors ob))
(mapc #'(lambda (single-listener)
- (add-error single-listener tcase condition))
- (listeners ob)))
+ (add-error single-listener tcase condition))
+ (listeners ob)))
(defmethod add-failure ((ob test-results) (tcase test-case) condition)
(push (make-test-failure tcase condition) (failures ob))
(mapc #'(lambda (single-listener)
- (add-failure single-listener tcase condition))
- (listeners ob)))
+ (add-failure single-listener tcase condition))
+ (listeners ob)))
((name :initform "" :initarg :name :reader test-suite-name)
(tests :initarg :tests :accessor tests :initform nil)
(description :initarg :description :reader description
- :initform "No description.")))
+ :initform "No description.")))
(defmacro get-suite (class-name)
`(suite (make-instance ',class-name)))
-
+
(defmethod add-test ((ob test-suite) (new-test test))
(remove-test new-test ob)
(defmethod run-on-test-results ((ob test-suite) (result test-results)
- &key (handle-errors t))
+ &key (handle-errors t))
(mapc #'(lambda (composite) ;;test-case or suite
(run-on-test-results composite result
- :handle-errors handle-errors))
+ :handle-errors handle-errors))
(tests ob)))
(defmethod named-test (name (suite test-suite))
(some (lambda (test-or-suite)
- (when (and (typep test-or-suite 'test-case)
- (equal name (name test-or-suite)))
- test-or-suite))
- (tests suite)))
+ (when (and (typep test-or-suite 'test-case)
+ (equal name (name test-or-suite)))
+ test-or-suite))
+ (tests suite)))
(defmethod remove-test ((test test) (suite test-suite))
(setf (tests suite)
(delete-if #'(lambda (existing-tests-or-suite)
- (cond ((typep existing-tests-or-suite 'test-suite)
- (eq existing-tests-or-suite test))
- ((typep existing-tests-or-suite 'test-case)
- (eql (name existing-tests-or-suite)
- (name test)))))
- (tests suite))))
+ (cond ((typep existing-tests-or-suite 'test-suite)
+ (eq existing-tests-or-suite test))
+ ((typep existing-tests-or-suite 'test-case)
+ (eql (name existing-tests-or-suite)
+ (name test)))))
+ (tests suite))))
;; Dynamic test suite
class of an instance and whose name begins with the string 'test-'.
This is used to dynamically generate a list of tests for a fixture."
(let ((res)
- (package (symbol-package (class-name (class-of instance)))))
+ (package (symbol-package (class-name (class-of instance)))))
(do-symbols (s package)
(when (and (> (length (symbol-name s)) 5)
- (string-equal "test-" (subseq (symbol-name s) 0 5))
- (fboundp s)
- (typep (symbol-function s) 'generic-function)
- (ignore-errors
- (plusp (length (compute-applicable-methods
- (ensure-generic-function s)
- (list instance))))))
- (push s res)))
+ (string-equal "test-" (subseq (symbol-name s) 0 5))
+ (fboundp s)
+ (typep (symbol-function s) 'generic-function)
+ (ignore-errors
+ (plusp (length (compute-applicable-methods
+ (ensure-generic-function s)
+ (list instance))))))
+ (push s res)))
(nreverse res)))
(defmacro def-test-method (method-name ((instance-name class-name)
- &key (run t))
- &body method-body)
+ &key (run t))
+ &body method-body)
`(let ((,instance-name
(make-instance ',class-name
:name ',method-name)))
(setf (method-body ,instance-name)
#'(lambda() ,@method-body))
(add-test (suite ,instance-name) ,instance-name)
- (when ,run
+ (when ,run
(textui-test-run ,instance-name))))
(defclass test-case (test)
((existing-suites :initform nil :accessor existing-suites
- :allocation :class)
+ :allocation :class)
(method-body
:initarg :method-body :accessor method-body :initform nil
:documentation
"A function designator which will be applied to this instance
to perform that test-case.")
(name :initarg :name :reader name :initform ""
- :documentation "The name of this test-case, used in reports.")
+ :documentation "The name of this test-case, used in reports.")
(description :initarg :description :reader description
- :documentation
- "Short description of this test-case, uses in reports")
+ :documentation
+ "Short description of this test-case, uses in reports")
(suite :initform nil :accessor suite :initarg :suite))
(:documentation
"Base class for test-cases."))
(setf (gethash (type-of ob) (existing-suites ob))
(make-instance 'test-suite))) ;;specifi suite singleton
(setf (suite ob) (gethash (type-of ob) (existing-suites ob))))
-
+
(defgeneric set-up (test)
(:documentation
res))
(defmethod run-on-test-results ((test test-case) result
- &key (handle-errors t))
+ &key (handle-errors t))
(start-test test result)
(run-protected test result :handle-errors handle-errors)
(end-test test result))
(defmethod run-protected ((test test-case) res &key (handle-errors t))
(if handle-errors
(handler-case
- (run-base test)
- (assertion-failed (condition)
- (add-failure res test condition))
- (serious-condition (condition)
- (add-error res test condition)))
+ (run-base test)
+ (assertion-failed (condition)
+ (add-failure res test condition))
+ (serious-condition (condition)
+ (add-error res test condition)))
(run-base test))
res)
(defmethod tear-down ((self was-run))
(setf (ws-log self)
- (concatenate 'string (ws-log self) "teardown ")))
+ (concatenate 'string (ws-log self) "teardown ")))
(def-test-method test-method ((self was-run) :run nil)
- (setf (ws-log self)
+ (setf (ws-log self)
(concatenate 'string (ws-log self) "test-method ")))
(def-test-method test-broken-method ((self was-run) :run nil)
#+ignore
(def-test-method test-not-condition-with-cond ((self was-run) :run nil)
- (assert-not-condition 'test-condition
- (signal 'test-condition)))
+ (assert-not-condition 'test-condition
+ (signal 'test-condition)))
;;; Second helper test case
(assert-equal (ws-log test) "setup test-method teardown ")))
(def-test-method test-results ((self test-case-test) :run nil)
- (assert-equal "1 run, 0 erred, 0 failed"
- (summary (run (named-test 'test-method
- (get-suite was-run))))))
+ (assert-equal "1 run, 0 erred, 0 failed"
+ (summary (run (named-test 'test-method
+ (get-suite was-run))))))
(def-test-method test-eql ((self test-case-test) :run nil)
- (assert-equal "1 run, 0 erred, 0 failed"
- (summary (run (named-test 'test-eql (get-suite was-run))))))
+ (assert-equal "1 run, 0 erred, 0 failed"
+ (summary (run (named-test 'test-eql (get-suite was-run))))))
(def-test-method test-not-eql ((self test-case-test) :run nil)
- (assert-equal "1 run, 0 erred, 0 failed"
- (summary (run (named-test 'test-not-eql
- (get-suite was-run))))))
+ (assert-equal "1 run, 0 erred, 0 failed"
+ (summary (run (named-test 'test-not-eql
+ (get-suite was-run))))))
(def-test-method test-fn ((self test-case-test) :run nil)
(let ((test (make-instance 'test-case :name 'test-fn
- :method-body
- (lambda ()
- (declare (ignore test))
- (assert-equal 10 10)))))
+ :method-body
+ (lambda ()
+ (declare (ignore test))
+ (assert-equal 10 10)))))
(assert-equal "1 run, 0 erred, 0 failed"
- (summary (run test)))))
+ (summary (run test)))))
(def-test-method test-failed-result ((self test-case-test) :run nil)
(assert-equal "1 run, 0 erred, 1 failed"
- (summary (run
- (named-test 'test-broken-method
- (get-suite was-run))))))
+ (summary (run
+ (named-test 'test-broken-method
+ (get-suite was-run))))))
(def-test-method test-error-result ((self test-case-test) :run nil)
(assert-equal "1 run, 1 erred, 0 failed"
- (summary (run
- (named-test 'test-error-method
- (get-suite was-run))))))
-
+ (summary (run
+ (named-test 'test-error-method
+ (get-suite was-run))))))
+
(def-test-method test-suite ((self test-case-test) :run nil)
(let ((suite (make-instance 'test-suite))
- (result (make-test-results)))
+ (result (make-test-results)))
(add-test suite (named-test 'test-method (get-suite was-run)))
(add-test suite (named-test 'test-broken-method (get-suite was-run)))
(run-on-test-results suite result)
(assert-equal "2 run, 0 erred, 1 failed" (summary result))))
(def-test-method test-dynamic-suite ((self test-case-test) :run nil)
- (assert-equal "2 run, 0 erred, 0 failed"
- (summary (run (get-suite test-two-cases)))))
+ (assert-equal "2 run, 0 erred, 0 failed"
+ (summary (run (get-suite test-two-cases)))))
(def-test-method test-condition ((self test-case-test) :run nil)
- (assert-condition
- 'test-condition
+ (assert-condition
+ 'test-condition
(error 'test-condition)))
-(def-test-method test-condition-without-cond ((self test-case-test)
- :run nil)
+(def-test-method test-condition-without-cond ((self test-case-test)
+ :run nil)
(assert-equal "1 run, 0 erred, 1 failed"
- (summary (run
- (named-test 'test-condition-without-cond
- (get-suite was-run))))))
+ (summary (run
+ (named-test 'test-condition-without-cond
+ (get-suite was-run))))))
#+ignore
(def-test-method test-not-condition ((self test-case-test) :run nil)
- (assert-not-condition
- 'test-condition
+ (assert-not-condition
+ 'test-condition
(progn)))
#+ignore
-(def-test-method test-not-condition-with-cond ((self test-case-test)
- :run nil)
+(def-test-method test-not-condition-with-cond ((self test-case-test)
+ :run nil)
(assert-equal "1 run, 0 erred, 1 failed"
- (summary (run
- (named-test 'test-not-condition-with-cond
- (get-suite was-run))))))
-
-#+ignore
+ (summary (run
+ (named-test 'test-not-condition-with-cond
+ (get-suite was-run))))))
+
+#+ignore
(textui-test-run (get-suite test-case-test))
(defclass textui-test-runner (test-listener)
((ostream :initform nil :accessor ostream :initarg :ostream))
(:default-initargs :ostream *standard-output*))
-
+
(defmethod add-error ((ob textui-test-runner) test-case condition)
(declare (ignore test-case condition))
(format (ostream ob) "E"))
-
+
(defmethod add-failure ((ob textui-test-runner) test-case condition)
(declare (ignore test-case condition))
(format (ostream ob) "F"))
-
+
(defmethod start-test ((ob textui-test-runner) test-case)
(declare (ignore test-case))
(format (ostream ob) "."))
-
+
(defmethod textui-test-run ((ob test))
(let ((test-runner (make-instance 'textui-test-runner))
(result (make-instance 'test-results))
- (start-time (get-internal-real-time)))
+ (start-time (get-internal-real-time)))
(add-listener result test-runner)
(run-on-test-results ob result)
- (print-results test-runner result
- (/ (- (get-internal-real-time) start-time)
- internal-time-units-per-second))
+ (print-results test-runner result
+ (/ (- (get-internal-real-time) start-time)
+ internal-time-units-per-second))
result))
projects / xlunit.git / commitdiff