;;;; Authors: Kevin Rosenberg and Craig Brozefsky
;;;;
;;;; Put in public domain by Kevin Rosenberg and onShore, Inc
-;;;; $Id: src.lisp,v 1.1 2003/08/04 06:00:01 kevin Exp $
+;;;; $Id: src.lisp,v 1.2 2003/08/04 09:46:44 kevin Exp $
;;;; *************************************************************************
(in-package #:xltest)
setup method did for this instance."
t)
-(define-condition test-failure (simple-condition) ()
+(define-condition test-failure-condition (simple-condition)
+ ()
(:documentation "Base class for all test failures."))
+(defclass test-failure ()
+ ((failed-test :initarg :failed-test :reader failed-test)
+ (thrown-condition :initarg :thrown-condition :reader thrown-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)))))
+
+(defmethod is-failure ((failure test-failure))
+ (typep (thrown-condition failure) 'test-failure-condition))
+
(defun failure (format-str &rest args)
"Signal a test failure and exit the test."
- (signal 'test-failure
+ (signal 'test-failure-condition
:format-control format-str
:format-arguments args))
-(defmacro test-assert (test)
+(defmacro test-assert (test &optional msg)
`(unless ,test
- (failure "Test assertion failed: ~s" ',test)))
+ (failure "Test assertion: ~s" ',test)))
-(defun assert-equal (v1 v2)
+(defun assert-equal (v1 v2 &optional msg)
(unless (equal v1 v2)
- (failure "Test equals failed: ~s ~s" v1 v2)))
+ (failure "Test equal: ~s ~s" v1 v2)))
-(defun assert-true (v)
+(defun assert-true (v &optional msg)
(unless v
- (failure "Test true failed: ~s" v)))
+ (failure "Test true: ~s [~A]" v (if msg msg ""))))
-(defun assert-false (v)
+(defun assert-false (v &optional msg)
(when v
- (failure "Test false failed")))
+ (failure "Test false ~A" (if msg msg ""))))
(defmethod perform-test ((test test-fixture))
,cleanup)
(progn ,protected ,cleanup)))
-(defmethod run-test ((test test-fixture) &key (handle-errors t))
+(defclass test-result ()
+ ((test :initarg :test :reader result-test)
+ (count :initform 0 :accessor test-count)
+ (failures :initarg :failures :reader test-failures :initform nil)
+ (errors :initarg :errors :reader test-errors :initform nil))
+ (:documentation "The result of applying a test"))
+
+(defclass test-suite ()
+ ((name :initarg :name :reader test-suite-name)
+ (tests :initarg :tests :accessor tests-hash
+ :initform (make-hash-table :test 'equal))
+ (description :initarg :description :reader description
+ :initform "No description.")))
+
+(defmethod setup-testsuite-named (name)
+ (declare (ignore name))
+ t)
+
+(defmethod teardown-testsuite-named (name)
+ (declare (ignore name))
+ t)
+
+(defmethod run-test ((suite test-suite) (result test-result)
+ &key (handle-errors t))
+ (setup-testsuite-named (slot-value suite 'name))
+ (dolist (test (tests suite))
+ (run-test test result :handle-errors handle-errors))
+ (teardown-testsuite-named (slot-value suite 'name))
+ (values))
+
+(defmethod run-test ((test test-fixture) result &key (handle-errors t))
"Perform the test represented by the given test-case or test-suite.
Returns one or more test-result objects, one for each test-case
performed."
- (let ((failures ())
- (errs ()))
+ (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-thunk test) test))))
- (if (typep res 'test-failure)
- (setf failures (cons res failures))))
- (test-failure (failure)
- (setf failures (cons failure failures)))
- (t (err)
- (setf errs (cons err errs))))
- (handler-case-if handle-errors
- (teardown test)
- (t (err)
- (setf errs (cons err errs)))))
- (make-instance 'test-result
- :test test
- :failures failures
- :errors errs)))
-
-(defmacro def-test-fixture (name supers slotdefs &rest class-options)
- "Define a new test-fixture class. Works just like defclass, but
-ensure that test-fixture is a super."
- `(defclass ,name ,(append supers (list 'test-fixture))
- ,slotdefs ,@class-options))
-
-(defun make-test-case (name fixture &key
- (test-thunk 'perform-test)
- (test-suite nil)
- (description nil))
+ (if (typep res 'test-failure-condition)
+ (push (make-instance 'test-failure
+ :failed-test test
+ :thrown-condition res)
+ failures)))
+ (test-failure-condition (failure)
+ (push (make-instance 'test-failure
+ :failed-test test
+ :thrown-condition failure)
+ failures))
+ (error (err)
+ (push (make-instance 'test-failure
+ :failed-test test
+ :thrown-condition err)
+ errors)))
+ (if handle-errors
+ (handler-case
+ (teardown test)
+ (error (err)
+ (push
+ (make-instance 'test-failure
+ :failed-test test :thrown-condition err)
+ errors)))
+ (teardown test))))
+ (values))
+
+
+(defun make-test (fixture name &key test-thunk test-suite description)
"Create a test-case which is an instance of FIXTURE. TEST-THUNK is
the method that will be invoked when perfoming this test, and can be a
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 name
- :test-thunk test-thunk
+ :test-name (string name)
+ :test-thunk
+ (if(and (symbolp name) (null test-thunk))
+ name
+ test-thunk)
:description description)))
(if test-suite (add-test newtest test-suite))
newtest))
-(defclass test-suite ()
- ((name :initarg :name :reader test-suite-name)
- (tests :initarg :tests :accessor tests-hash
- :initform (make-hash-table :test 'equal))
- (description :initarg :description :reader description
- :initform "No description.")))
-
(defmethod tests ((suite test-suite))
(let ((tlist nil))
(maphash #'(lambda (k v)
(let ((suite (make-instance 'test-suite :name name-or-fixture
:description description)))
(dolist (testspec testspecs)
- (add-test (apply #'make-test-case testspec) suite))
+ (add-test (apply #'make-test testspec) suite))
suite))))
(defmethod add-test ((test test-fixture) (suite test-suite))
(defmethod test-named ((name string) (suite test-suite))
(gethash name (tests-hash suite)))
-(defmethod setup-testsuite-named (name)
- (declare (ignore name))
- t)
-
-(defmethod teardown-testsuite-named (name)
- (declare (ignore name))
- t)
-
-(defmethod run-test ((suite test-suite) &key (handle-errors t))
- (let ((start-time (get-internal-real-time)))
- (setup-testsuite-named (slot-value suite 'name))
- (let ((res (mapcar (lambda (test) (run-test test
- :handle-errors handle-errors))
- (tests suite))))
- (teardown-testsuite-named (slot-value suite 'name))
- (make-instance 'suite-results
- :suite suite
- :test-results res
- :start-time start-time
- :stop-time (get-internal-real-time)))))
-
-
-(defclass test-result ()
- ((test :initarg :test :reader result-test)
- (failures :initarg :failures :reader test-failures :initform nil)
- (errors :initarg :errors :reader test-errors :initform nil))
- (:documentation "The result of applying a test"))
-
-(defclass suite-results ()
- ((suite :initarg :suite :reader suite)
- (start-time :initarg :start-time :reader start-time)
- (stop-time :initarg :stop-time :reader stop-time)
- (test-results :initarg :test-results :reader test-results))
- (:documentation "Results of running a suite"))
-
-
-(defmethod report-result ((result test-result) &key (stream t)
- (verbose nil))
- "Print out a test-result object for a report to STREAM, default to
-standard-output. If VERBOSE is non-nil then will produce a lengthy
-and informative report, otherwise just prints wether the test passed
-or failed or errored out."
- (when (or verbose (test-failures result) (test-errors result))
- (when verbose
- (format stream
- "------------------------------------------------------~%"))
- (format stream "~A~A"
- (test-name (result-test result))
- (cond
- ((test-failures result) ":")
- ((test-errors result) ":")
- (t ": Passed")))
- (when (test-failures result)
- (format stream " Failures: ~{~A~^; ~}" (test-failures result)))
- (when (test-errors result)
- (format stream " Errors: ~{~A~^; ~}" (test-errors result)))
- (fresh-line stream)
- (when verbose
- (when (description (result-test result))
- (format stream "Description: ~A~%"
- (description (result-test result)))))))
-
-(defmethod report-result ((results suite-results) &key (stream t)
- (verbose nil))
- (format stream "~&.............~%")
- (format stream "~&Time: ~D~%"
- (float
- (/ (- (stop-time results) (start-time results))
- internal-time-units-per-second)))
- (if (some (lambda (res) (or (test-failures res) (test-errors res)))
- (test-results results))
- (dolist (foo (test-results results))
- (report-result foo :stream stream :verbose verbose))
- (format stream "~&OK (~D tests)~%" (length (test-results results)))))
-
+(defmethod was-successful ((result test-result))
+ (and (null (test-failures result))
+ (null (test-errors result))))
+
+(defmethod text-testrunner ((suite test-suite) &key (stream t)
+ (handle-errors t))
+ (let ((result (make-instance 'test-result))
+ (start-time (get-internal-real-time)))
+ (run-test suite result :handle-errors handle-errors)
+ (let ((seconds (/ (- (get-internal-real-time) start-time)
+ internal-time-units-per-second)))
+ (result-printer result seconds stream))))
+
+(defun result-printer (result seconds stream)
+ (format stream "~&Time: ~D~%~%" (coerce seconds 'float))
+ (print-defects (test-errors result) "error" stream)
+ (print-defects (test-failures result) "failure" stream)
+ (if (was-successful result)
+ (format stream "OK (~D tests)~%" (test-count result))
+ (progn
+ (format stream "~%FAILURES!!!~%")
+ (format stream "Tests run: ~D, Failures: ~D, Errors: ~D~%"
+ (test-count result) (length (test-failures result))
+ (length (test-errors result))))))
+
+(defun print-defects (defects type stream)
+ (when defects
+ (let ((count (length defects)))
+ (if (= count 1)
+ (format stream "~&There was ~D ~A:~%" count type)
+ (format stream "~&There were ~D ~As:~%" count type))
+ (dotimes (i count)
+ (let ((defect (nth i defects)))
+ (format stream "~&~D) ~A " i (class-name
+ (class-of (failed-test defect))))
+ (apply #'format stream (simple-condition-format-control
+ (thrown-condition defect))
+ (simple-condition-format-arguments
+ (thrown-condition defect)))
+ (fresh-line stream))))))
+
+(defmethod summary ((result test-result))
+ (format nil "~D run, ~D errored, ~D failed"
+ (test-count result) (length (test-errors result))
+ (length (test-failures result))))
;;; Dynamic test suite addition by Kevin Rosenberg 8/2003
:description description))
(fns (find-test-generic-functions fixture)))
(dolist (fn fns)
- (make-test-case fn (class-name (class-of fixture))
- :test-thunk fn
- :test-suite suite))
+ (make-test (class-name (class-of fixture)) fn
+ :test-suite suite))
suite))
(defun find-test-generic-functions (instance)
(let ((res)
(package (symbol-package (class-name (class-of instance)))))
(do-symbols (s package)
- (multiple-value-bind (sym status)
- (find-symbol (symbol-name s) package)
- (when (and (or (eq status :external)
- (eq status :internal))
- (fboundp sym)
- (eq (symbol-package sym) package)
- (> (length (symbol-name sym)) 5)
- (string-equal "test-" (subseq (symbol-name sym) 0 5))
- (typep (symbol-function sym) 'generic-function)
- (plusp
- (length
- (compute-applicable-methods
- (ensure-generic-function sym)
- (list instance)))))
- (push sym res))))
+ (when (and (> (length (symbol-name s)) 5)
+ (string-equal "test-" (subseq (symbol-name s) 0 5))
+ (fboundp s)
+ (typep (symbol-function s) 'generic-function)
+ (plusp (length (compute-applicable-methods
+ (ensure-generic-function s)
+ (list instance)))))
+ (push s res)))
(nreverse res)))
projects / xlunit.git / blobdiff