r5452: *** empty log message ***
authorKevin M. Rosenberg <kevin@rosenberg.net>
Mon, 4 Aug 2003 16:13:58 +0000 (16:13 +0000)
committerKevin M. Rosenberg <kevin@rosenberg.net>
Mon, 4 Aug 2003 16:13:58 +0000 (16:13 +0000)
assert.lisp
example.lisp
listener.lisp [new file with mode: 0644]
package.lisp
printer.lisp
result.lisp
suite.lisp
test-case.lisp [new file with mode: 0644]
tests.lisp
textui.lisp [new file with mode: 0644]
xlunit.asd

index 460bb4d07a92cc1246a0a9913a2ff92ffb9f21e9..fa2f100e92a216cf3bec1e0a4872b301e8e564e6 100644 (file)
@@ -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
 ;;;;
 ;;;; *************************************************************************
 (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))
   "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)))
index 5265bcad013c22c928e533a01f3a3fc5d8ecb62f..3fc9e3a2ce65a1cb3cd7c15a2291f29899bf87a0 100644 (file)
@@ -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
 ;;;;
 ;;;; *************************************************************************
 ;;; 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))
 
 ;;; 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 (file)
index 0000000..0586593
--- /dev/null
@@ -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)))
+
+          
index c2b1780eae6d4cc6890996f52f7af148006d30b7..6b58890dac78fc1cec7c4107b5edcc41fcaee129 100644 (file)
@@ -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)
   (: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
index af4adfc32694981fdbb334d027ee2bd4b128ee0c..729e0839e129a8814553a37e70872315f33add25 100644 (file)
@@ -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
 ;;;;
 ;;;; *************************************************************************
 (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)))
index e601ec64ac8a89671f861c5da0cef490579c6539..3ddead3d9fcd39df3a24b2b28db7d517afc6015f 100644 (file)
@@ -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
 ;;;;
 ;;;; *************************************************************************
 
 (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
 
 (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)))
+
index e410b5daa958d8708d75e2ec9009f6280f2b17a0..4a64425c9c89a870e3f5dbb96da25195c5552c83 100644 (file)
@@ -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
 ;;;;
 ;;;; *************************************************************************
 (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))
   (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 (file)
index 0000000..a61627b
--- /dev/null
@@ -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))
index 892a0335d7fc528d2d3a4d6fada16dc934e40edd..e5cfb41dfc2b8856c2eef3a8d275f6e2d2f13bc7 100644 (file)
@@ -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 (file)
index 0000000..92dbfb3
--- /dev/null
@@ -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))))
+                                                                                 
index 9cd8bdba2138243763c0cf8ac7efd712c92e301e..f6f3d44445fb65f61ef6b507471016ae47973ec4 100644 (file)
@@ -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))
   :components
   ((:file "package")
    (:file "assert")
-   (:file "fixture")
+   (:file "test-case")
    (:file "suite")
+   (:file "listener")
    (:file "result")
+   (:file "textui")
    (:file "printer")
    ))