From 53e193feda5d4cb757ef13d622fac03cf99178a2 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Mon, 4 Aug 2003 16:13:58 +0000 Subject: [PATCH] r5452: *** empty log message *** --- assert.lisp | 16 +++--- example.lisp | 32 ++++------- listener.lisp | 21 +++++++ package.lisp | 15 ++--- printer.lisp | 67 ++++++++++++++++++++--- result.lisp | 54 ++++++++++++++++-- suite.lisp | 99 ++++++++++++++++++--------------- test-case.lisp | 146 +++++++++++++++++++++++++++++++++++++++++++++++++ tests.lisp | 8 +-- textui.lisp | 40 ++++++++++++++ xlunit.asd | 6 +- 11 files changed, 403 insertions(+), 101 deletions(-) create mode 100644 listener.lisp create mode 100644 test-case.lisp create mode 100644 textui.lisp diff --git a/assert.lisp b/assert.lisp index 460bb4d..fa2f100 100644 --- a/assert.lisp +++ b/assert.lisp @@ -2,7 +2,7 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; ID: $Id: assert.lisp,v 1.3 2003/08/04 12:28:46 kevin Exp $ +;;;; ID: $Id: assert.lisp,v 1.4 2003/08/04 16:13:58 kevin Exp $ ;;;; Purpose: Assert functions for XLUnit ;;;; ;;;; ************************************************************************* @@ -10,16 +10,14 @@ (in-package #:xlunit) -;;; Assertions - -(define-condition test-failure-condition (simple-condition) +(define-condition assertion-failed (simple-condition) ((msg :initform nil :initarg :msg :accessor msg)) (:documentation "Base class for all test failures.")) (defun failure-msg (msg &optional format-str &rest args) "Signal a test failure and exit the test." - (signal 'test-failure-condition + (signal 'assertion-failed :msg msg :format-control format-str :format-arguments args)) @@ -28,14 +26,14 @@ "Signal a test failure and exit the test." (apply #'failure-msg nil format-str args)) -(defmacro test-assert (test &optional msg) - `(unless ,test - (failure-msg ,msg "Test assertion: ~s" ',test))) - (defun assert-equal (v1 v2 &optional msg) (unless (equal v1 v2) (failure-msg msg "Test equal: ~S ~S" v1 v2))) +(defun assert-eql (v1 v2 &optional msg) + (unless (eql v1 v2) + (failure-msg msg "Test eql: ~S ~S" v1 v2))) + (defmacro assert-true (v &optional msg) `(unless ,v (failure-msg msg "Not true: ~S" ',v))) diff --git a/example.lisp b/example.lisp index 5265bca..3fc9e3a 100644 --- a/example.lisp +++ b/example.lisp @@ -2,7 +2,7 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; ID: $Id: example.lisp,v 1.4 2003/08/04 12:16:13 kevin Exp $ +;;;; ID: $Id: example.lisp,v 1.5 2003/08/04 16:13:58 kevin Exp $ ;;;; Purpose: Example file for XLUnit ;;;; ;;;; ************************************************************************* @@ -16,19 +16,19 @@ ;;; First we define some basic fixtures that we are going to need to ;;; perform our tests. A fixture is a place to hold data we need ;;; during testing. Often there are many test cases that use the same -;;; data. Each of these test cases is an instance of a test-fixture. +;;; data. Each of these test cases is an instance of a test-case. -(defclass math-fixture (test-fixture) +(defclass math-fixture (test-case) ((numbera :accessor numbera) (numberb :accessor numberb)) (:documentation "Test fixture for math testing")) -;;; Then we define a setup method for the fixture. This method is run +;;; Then we define a set-up method for the fixture. This method is run ;;; prior to perfoming any test with an instance of this fixture. It ;;; should perform all initialization needed, and assume that it is starting ;;; with a pristine environment, well to a point, use your head here. -(defmethod setup ((fix math-fixture)) +(defmethod set-up ((fix math-fixture)) (setf (numbera fix) 2) (setf (numberb fix) 3)) @@ -39,34 +39,22 @@ ;;; otherwise get rid of state built up while perofmring the test. ;;; Here we just return T. -(defmethod teardown ((fix math-fixture)) +(defmethod tear-down ((fix math-fixture)) t) -;;; Once we hav a fixture we can start defining method on it which -;;; will perform tests. These methods should take one argument, an -;;; instance of the fixture. The method performs some operation and -;;; then performs some tests to determine if the proper behavior -;;; occured. If there is a failure to behave as excpeted the method -;;; raises a test-failure object by calling the method FAILURE. This -;;; is much like calling ERROR in that it stops processing that -;;; method. Each method should only check for one aspect of behavior. -;;; This way triggering one failure would not result in another -;;; behavior check from being skipped. It does not matter what these -;;; methods return - -(defmethod test-addition ((test math-fixture)) +(def-test-method test-addition ((test math-fixture)) (let ((result (+ (numbera test) (numberb test)))) (test-assert (= result 5)))) -(defmethod test-subtraction ((test math-fixture)) +(def-test-method test-subtraction ((test math-fixture)) (let ((result (- (numberb test) (numbera test)))) (assert-equal result 1))) ;;; This method is meant to signal a failure -(defmethod test-subtraction-2 ((test math-fixture)) +(def-test-method test-subtraction-2 ((test math-fixture)) (let ((result (- (numbera test) (numberb test)))) (assert-equal result 1))) ;;;; Finally we can run our test suite and see how it performs. -(text-testrunner (make-test-suite 'math-fixture)) +(textui-test-run (make-test-suite 'math-fixture)) diff --git a/listener.lisp b/listener.lisp new file mode 100644 index 0000000..0586593 --- /dev/null +++ b/listener.lisp @@ -0,0 +1,21 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; ID: $Id: listener.lisp,v 1.1 2003/08/04 16:13:58 kevin Exp $ +;;;; Purpose: Listener functions for XLUnit +;;;; +;;;; ************************************************************************* + +(in-package #:xlunit) + +(defclass test-listener () + ()) + +(defmethod start-test ((obj test-listener) tcase) + (declare (ignore tcase))) + +(defmethod end-test ((obj test-listener) tcase) + (declare (ignore tcase))) + + diff --git a/package.lisp b/package.lisp index c2b1780..6b58890 100644 --- a/package.lisp +++ b/package.lisp @@ -2,10 +2,10 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; ID: $Id: package.lisp,v 1.5 2003/08/04 12:16:13 kevin Exp $ +;;;; ID: $Id: package.lisp,v 1.6 2003/08/04 16:13:58 kevin Exp $ ;;;; Purpose: Package definition for XLUnit ;;;; -;;;; $Id: package.lisp,v 1.5 2003/08/04 12:16:13 kevin Exp $ +;;;; $Id: package.lisp,v 1.6 2003/08/04 16:13:58 kevin Exp $ ;;;; ************************************************************************* (in-package #:cl-user) @@ -14,23 +14,24 @@ (:use #:cl) (:export - ;; fixture - #:test-fixture + ;; test-case.lisp + #:test-case + #:def-test-method #:setup #:teardown #:run-test #:make-test ;; assert - #:assert-equal #:assert-true #:assert-false - #:test-assert + #:assert-equal + #:assert-eql #:test-failure #:failure ;; suite.lisp - #:text-testrunner + #:textui-test-run #:make-test-suite #:setup-testsuite-named #:teardown-testsuite-named diff --git a/printer.lisp b/printer.lisp index af4adfc..729e083 100644 --- a/printer.lisp +++ b/printer.lisp @@ -2,7 +2,7 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; ID: $Id: printer.lisp,v 1.2 2003/08/04 12:16:13 kevin Exp $ +;;;; ID: $Id: printer.lisp,v 1.3 2003/08/04 16:13:58 kevin Exp $ ;;;; Purpose: Printer functions for XLUnit ;;;; ;;;; ************************************************************************* @@ -10,17 +10,66 @@ (in-package #:xlunit) +;---------------------------------------------------------------------- +; method print-results +;---------------------------------------------------------------------- + +(defmethod print-results ((ob textui-test-runner) result seconds) + (format (ostream ob) "~&Time: ~D~%~%" (coerce seconds 'float)) + (print-header ob result) + (print-errors ob result) + (print-failures ob result) + t) + +(defmethod print-header ((ob textui-test-runner) result) + (let ((failures (failures result)) + (errors (errors result)) + (run-tests (run-tests result))) + (cond ((and (null failures) (null errors)) + (format (ostream ob) "~%OK (~a tests)~%" run-tests)) + (t + (format (ostream ob) "~%~%FAILURES!!!~%") + (format (ostream ob) "Run: ~a Failures: ~a Errors: ~a~%" + run-tests (length failures) (length errors)))))) + +(defmethod print-errors ((ob textui-test-runner) result) + (let ((errors (errors result))) + (when errors + (if (eql (length errors) 1) + (format (ostream ob) "~%There was 1 error:~%") + (format (ostream ob) "~%There were ~a errors:~%" (length errors))) + (let ((i 1)) + (mapc #'(lambda (single-error) + (format (ostream ob) "~a) ~a: ~a~%" i + (name (car single-error)) (cdr single-error)) + (incf i)) + errors))))) + +(defmethod print-failures ((ob textui-test-runner) result) + (let ((failures (failures result))) + (when failures + (if (eql (length failures) 1) + (format (ostream ob) "~%There was 1 failure:~%") + (format (ostream ob) "~%There were ~a failures:~%" (length failures))) + (let ((i 1)) + (mapc #'(lambda (single-failure) + (format (ostream ob) "~a) ~a: ~a~%" i (name (car single-failure)) + (or (message (cdr single-failure)) "")) + (incf i)) + failures))))) + +#| (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) + (print-defects (errors result) "error" stream) + (print-defects (failures result) "failure" stream) (if (was-successful result) - (format stream "OK (~D tests)~%" (test-count result)) + (format stream "OK (~D tests)~%" (run-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)))))) + (run-count result) (failure-count result) + (error-count result))))) (defun print-defects (defects type stream) (when defects @@ -38,7 +87,9 @@ (thrown-condition defect))) (fresh-line stream)))))) +|# + +(defgeneric summary (result)) (defmethod summary ((result test-result)) (format nil "~D run, ~D erred, ~D failed" - (test-count result) (length (test-errors result)) - (length (test-failures result)))) + (run-count result) (error-count result) (failure-count result))) diff --git a/result.lisp b/result.lisp index e601ec6..3ddead3 100644 --- a/result.lisp +++ b/result.lisp @@ -2,7 +2,7 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; ID: $Id: result.lisp,v 1.3 2003/08/04 12:28:46 kevin Exp $ +;;;; ID: $Id: result.lisp,v 1.4 2003/08/04 16:13:58 kevin Exp $ ;;;; Purpose: Result functions for XLUnit ;;;; ;;;; ************************************************************************* @@ -12,14 +12,39 @@ (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)) + (count :initform 0 :accessor run-tests) + (failures :initarg :failures :accessor failures :initform nil) + (errors :initarg :errors :accessor errors :initform nil) + (listeners :initform nil :accessor listeners) + (stop :initform nil :accessor stop)) (:documentation "Results of running test(s)")) +(defmethod failure-count ((res test-result)) + (length (failures res))) + +(defmethod error-count ((res test-result)) + (length (errors res))) + (defun make-test-result () (make-instance 'test-result)) + +(defmethod start-test ((tcase test) (res test-result)) + (incf (run-tests res)) + (mapc (lambda (listener) (start-test listener tcase)) (listeners res)) + res) + +(defmethod end-test ((tcase test) (res test-result)) + (incf (run-tests res)) + (mapc (lambda (listener) (end-test listener tcase)) (listeners res)) + res) + +(defmethod add-listener ((res test-result) (listener test-listener)) + (push listener (listeners res))) + + +;; Test Failures + (defclass test-failure () ((failed-test :initarg :failed-test :reader failed-test) (thrown-condition :initarg :thrown-condition @@ -43,4 +68,23 @@ (defmethod was-successful ((result test-result)) "Returns T if a result has no failures or errors" - (and (null (test-failures result)) (null (test-errors result)))) + (and (null (failures result)) (null (errors result)))) + + +;---------------------------------------------------------------------- +; methods add-error, add-failure +;---------------------------------------------------------------------- + +(defmethod add-error ((ob test-result) (tcase test-case) condition) + (push (make-test-failure tcase condition) (errors ob)) + (mapc #'(lambda (single-listener) + (add-error single-listener tcase condition)) + (listeners ob))) + + +(defmethod add-failure ((ob test-result) (tcase test-case) condition) + (push (make-test-failure tcase condition) (failures ob)) + (mapc #'(lambda (single-listener) + (add-failure single-listener tcase condition)) + (listeners ob))) + diff --git a/suite.lisp b/suite.lisp index e410b5d..4a64425 100644 --- a/suite.lisp +++ b/suite.lisp @@ -2,7 +2,7 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; ID: $Id: suite.lisp,v 1.2 2003/08/04 12:16:13 kevin Exp $ +;;;; ID: $Id: suite.lisp,v 1.3 2003/08/04 16:13:58 kevin Exp $ ;;;; Purpose: Suite functions for XLUnit ;;;; ;;;; ************************************************************************* @@ -10,12 +10,14 @@ (in-package #:xlunit) (defclass test-suite () - ((name :initarg :name :reader test-suite-name) - (tests :initarg :tests :accessor tests-hash - :initform (make-hash-table :test 'equal)) + ((name :initform "" :initarg :name :reader test-suite-name) + (tests :initarg :tests :accessor tests :initform nil) (description :initarg :description :reader description :initform "No description."))) +(defmacro get-suite (class-name) + `(suite (make-instance ',class-name))) + (defmethod setup-testsuite-named (name) (declare (ignore name)) @@ -25,53 +27,37 @@ (declare (ignore name)) t) -(defmethod run-test ((suite test-suite) +(defmethod run-on-test ((suite test-suite) &key (result (make-instance 'test-result)) (handle-errors t)) (setup-testsuite-named (slot-value suite 'name)) (dolist (test (tests suite)) - (run-test test :result result :handle-errors handle-errors)) + (run-on-test test :result result :handle-errors handle-errors)) (teardown-testsuite-named (slot-value suite 'name)) result) -(defmethod tests ((suite test-suite)) - (let ((tlist nil)) - (maphash #'(lambda (k v) - (declare (ignore k)) - (setf tlist (cons v tlist))) - (tests-hash suite)) - (reverse tlist))) +(defmethod add-test ((ob test-suite) (new-test test)) + (setf (tests ob) + (delete-if #'(lambda (existing-tests-or-suite) + (cond ((typep existing-tests-or-suite 'test-suite) + (eq existing-tests-or-suite new-test)) + ((typep existing-tests-or-suite 'test-case) + (eql (name existing-tests-or-suite) + (name new-test))))) + (tests ob))) + (setf (tests ob) (append (tests ob) (list new-test)))) -(defun make-test-suite (name-or-fixture &optional description testspecs) - "Returns a new test-suite based on a name and TESTSPECS or a fixture -instance" - (etypecase name-or-fixture - (symbol - (make-test-suite-for-fixture (make-instance name-or-fixture))) - (string - (let ((suite (make-instance 'test-suite :name name-or-fixture - :description description))) - (dolist (testspec testspecs) - (add-test (apply #'make-test testspec) suite)) - suite)))) - - -(defmethod add-test ((test test-fixture) (suite test-suite)) - (setf (gethash (test-name test) (tests-hash suite)) test)) - -(defmethod add-test ((test test-suite) (suite test-suite)) - (setf (gethash (test-suite-name test) (tests-hash suite)) test)) - -(defmethod remove-test ((test test-fixture) (suite test-suite)) - (remhash (test-name test) (tests-hash suite))) +#| +(defmethod remove-test ((test test-case) (suite test-suite)) + (remhash (name test) (tests-hash suite))) (defmethod remove-test ((test test-suite) (suite test-suite)) (remhash (test-suite-name test) (tests-hash suite))) -(defmethod test-named ((name string) (suite test-suite)) +(defmethod named ((name string) (suite test-suite)) (gethash name (tests-hash suite))) - +|# ;; Dynamic test suite @@ -79,8 +65,8 @@ instance" (fixture &key (name (format nil "Automatic for ~A" - (if (slot-boundp fixture 'test-name) - (test-name fixture) + (if (slot-boundp fixture 'name) + (name fixture) (type-of fixture)))) description) (let ((suite (make-instance 'test-suite @@ -103,19 +89,44 @@ This is used to dynamically generate a list of tests for a fixture." (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))))) + (ignore-errors + (plusp (length (compute-applicable-methods + (ensure-generic-function s) + (list instance)))))) (push s res))) (nreverse res))) +;---------------------------------------------------------------------- +; macro def-test-method +; +; Creates the representation of a test method (included within a +; test-case object) and add it to the corresponding suite class. +; => clos version of the pluggable selector pattern +; +; use: (def-test-method test-assert-false (clos-unit-test) +; (assert-true (eql (+ 1 2) 4) "comment")) +; +; new: it calls the textui-test-run function during eval, so to +; allow the usual lisp-like incremental developing and test. +;---------------------------------------------------------------------- + +(defmacro def-test-method (method-name class-name &body method-body) + `(let ((,(caar class-name) + (make-instance ',(cadar class-name) + :name ',method-name))) + (setf (method-body ,(caar class-name)) + #'(lambda() ,@method-body)) + (add-test (suite ,(caar class-name)) ,(caar class-name)) + (textui-test-run ,(caar class-name)))) + + ;;; Test Runners -(defmethod text-testrunner ((suite test-suite) &key (stream t) +(defmethod textui-test-run ((suite test-suite) &key (stream t) (handle-errors t)) (let* ((start-time (get-internal-real-time)) - (result (run-test suite :handle-errors handle-errors)) + (result (run-on-test suite :handle-errors handle-errors)) (seconds (/ (- (get-internal-real-time) start-time) internal-time-units-per-second))) (result-printer result seconds stream))) diff --git a/test-case.lisp b/test-case.lisp new file mode 100644 index 0000000..a61627b --- /dev/null +++ b/test-case.lisp @@ -0,0 +1,146 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; ID: $Id: test-case.lisp,v 1.1 2003/08/04 16:13:58 kevin Exp $ +;;;; Purpose: Test fixtures for XLUnit +;;;; +;;;; ************************************************************************* + +(in-package #:xlunit) + + +(defclass test () + ()) + +(defclass test-case (test) + ((existing-suites :initform nil :accessor existing-suites + :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 + :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") + (suite :initform nil :accessor suite :initarg :suite)) + (:documentation + "Base class for test-cases.")) + +(defmethod initialize-instance :after ((ob test-case) &rest initargs) + (declare (ignore initargs)) + (if (null (existing-suites ob)) + (setf (existing-suites ob) (make-hash-table))) ;;hash singleton + (unless (gethash (type-of ob) (existing-suites ob)) + (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 + "Method called before performing a test, should set up the +environment the test-case needs to operate in.")) + +(defmethod set-up ((test test-case)) + ) + +(defgeneric tear-down (test) + (:documentation + "Method called after performing a test. Should reverse everything +that the setup method did for this instance.")) + +(defmethod tear-down ((test test-case)) + ) + + + +(defmethod run-on-test ((test test-case) + &key (result (make-instance 'test-result)) + (handle-errors t)) + (start-test test result) + (run-protected test result :handle-errors handle-errors) + (end-test test result)) + +(defmethod run-base ((test test-case)) + (set-up test) + (unwind-protect + (run-test test) + (tear-down test))) + +(defmethod run-test ((test test-case)) + (funcall (method-body test))) + +(defmethod run-protected ((test test-case) res &key (handle-errors t)) + (handler-case + (run-base test) + (assertion-failed (condition) + (add-failure res test condition)) + (serious-condition (condition) + (add-error res test condition))) + res) + + +(defmacro handler-case-if (test form &body cases) + `(if ,test + (handler-case + ,form + ,@cases) + ,form)) + +(defmacro unwind-protect-if (test protected cleanup) + `(if ,test + (unwind-protect + ,protected + ,cleanup) + (progn ,protected ,cleanup))) + +#| +(defmethod run-test ((test test-case) + &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 (run-count result)) + (with-slots (failures errors) result + (unwind-protect-if handle-errors + (handler-case-if handle-errors + (let ((res (progn (setup test) + (funcall (method-body 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) +|# + +(defun make-test (fixture name &key method-body test-suite description) + "Create a test-case which is an instance of FIXTURE. METHOD-BODY 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-case +instance. DESCRIPTION is obviously what it says it is." + (let ((newtest (make-instance fixture + :name (etypecase name + (symbol + (string-downcase (symbol-name name))) + (string + name)) + :method-body + (if (and (symbolp name) (null method-body)) + name + method-body) + :description description))) + (when test-suite (add-test newtest test-suite)) + newtest)) diff --git a/tests.lisp b/tests.lisp index 892a033..e5cfb41 100644 --- a/tests.lisp +++ b/tests.lisp @@ -2,7 +2,7 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Id: $Id: tests.lisp,v 1.6 2003/08/04 12:28:46 kevin Exp $ +;;;; Id: $Id: tests.lisp,v 1.7 2003/08/04 16:13:58 kevin Exp $ ;;;; Purpose: Test suite for XLUnit ;;;; ;;;; ************************************************************************* @@ -16,7 +16,7 @@ ;; Helper test fixture -(defclass was-run (test-fixture) +(defclass was-run (test-case) ((log :accessor ws-log))) (defmethod setup ((self was-run)) @@ -37,7 +37,7 @@ ;;; Main test fixture -(defclass test-case-test (test-fixture) +(defclass test-case-test (test-case) ()) (defmethod test-template-method ((self test-case-test)) @@ -80,7 +80,7 @@ (assert-equal "3 run, 1 erred, 1 failed" (summary (run-test (make-test-suite 'was-run))))) -(text-testrunner (make-test-suite 'test-case-test) :handle-errors nil) +(textui-test-run (make-test-suite 'test-case-test) :handle-errors nil) (defun do-tests () diff --git a/textui.lisp b/textui.lisp new file mode 100644 index 0000000..92dbfb3 --- /dev/null +++ b/textui.lisp @@ -0,0 +1,40 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; ID: $Id: textui.lisp,v 1.1 2003/08/04 16:13:58 kevin Exp $ +;;;; Purpose: Text UI for Test Runner +;;;; +;;;; ************************************************************************* + +(in-package #:xlunit) + +;;; Test Runners + +(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))) + (add-listener result test-runner) + (run-on-test-result ob result) + (print-results test-runner result + (/ (- (get-internal-real-time) start-time) + internal-time-units-per-second)))) + diff --git a/xlunit.asd b/xlunit.asd index 9cd8bdb..f6f3d44 100644 --- a/xlunit.asd +++ b/xlunit.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Aug 2003 ;;;; -;;;; $Id: xlunit.asd,v 1.2 2003/08/04 12:01:54 kevin Exp $ +;;;; $Id: xlunit.asd,v 1.3 2003/08/04 16:13:58 kevin Exp $ ;;;; ************************************************************************* (defpackage #:xlunit-system (:use #:asdf #:cl)) @@ -25,9 +25,11 @@ :components ((:file "package") (:file "assert") - (:file "fixture") + (:file "test-case") (:file "suite") + (:file "listener") (:file "result") + (:file "textui") (:file "printer") )) -- 2.34.1