X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=src.lisp;h=4896067b5a3f46c183c87cf6702450b57bf0fe7b;hb=274fc70849b8122372f0e114a917f23852ce7f20;hp=20c3f1ff0c1c8040897fd50fdf3577baa2e622e7;hpb=95c39c23a9d9db5b42fbc784ac75557fb1eb1a60;p=xlunit.git diff --git a/src.lisp b/src.lisp index 20c3f1f..4896067 100644 --- a/src.lisp +++ b/src.lisp @@ -6,11 +6,10 @@ ;;;; Purpose: eXtreme Lisp Test Suite ;;;; 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.3 2003/08/04 09:50:33 kevin Exp $ ;;;; ************************************************************************* -(in-package #:xltest) +(in-package #:xlunit) (defclass test-fixture () @@ -43,30 +42,45 @@ environment the test-case needs to operate in." 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)) @@ -87,59 +101,88 @@ setup method did for this instance." ,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) @@ -158,7 +201,7 @@ instance" (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)) @@ -176,81 +219,51 @@ instance" (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 @@ -267,9 +280,8 @@ or failed or errored out." :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) @@ -279,21 +291,14 @@ This is used to dynamically generate a list of tests for a fixture." (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)))