;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; ID: $Id: example.lisp,v 1.5 2003/08/04 16:13:58 kevin Exp $
+;;;; ID: $Id: example.lisp,v 1.6 2003/08/04 17:04:49 kevin Exp $
;;;; Purpose: Example file for XLUnit
;;;;
;;;; *************************************************************************
(in-package #:xlunit-example)
-;;; 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
+;;; First we define some basic test-cases that we are going to need to
+;;; perform our tests. A test-case 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-case.
-(defclass math-fixture (test-case)
+(defclass math-test-case (test-case)
((numbera :accessor numbera)
(numberb :accessor numberb))
- (:documentation "Test fixture for math testing"))
+ (:documentation "Test test-case for math testing"))
-;;; 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
+;;; Then we define a set-up method for the test-case. This method is run
+;;; prior to perfoming any test with an instance of this test-case. 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 set-up ((fix math-fixture))
- (setf (numbera fix) 2)
- (setf (numberb fix) 3))
+(defmethod set-up ((tcase math-test-case))
+ (setf (numbera tcase) 2)
+ (setf (numberb tcase) 3))
-;;; Then we define a teardown method, which should return the instance
-;;; to it's original form and reset the environment. In this case
-;;; there is little for us to do since the fixture is quite static.
-;;; In other cases we may need to clear some database tables, or
-;;; otherwise get rid of state built up while perofmring the test.
-;;; Here we just return T.
-
-(defmethod tear-down ((fix math-fixture))
- t)
-
-(def-test-method test-addition ((test math-fixture))
+(def-test-method test-addition ((test math-test-case))
(let ((result (+ (numbera test) (numberb test))))
- (test-assert (= result 5))))
+ (assert-true (= result 5))))
-(def-test-method test-subtraction ((test math-fixture))
+(def-test-method test-subtraction ((test math-test-case))
(let ((result (- (numberb test) (numbera test))))
(assert-equal result 1)))
;;; This method is meant to signal a failure
-(def-test-method test-subtraction-2 ((test math-fixture))
+(def-test-method test-subtraction-2 ((test math-test-case))
(let ((result (- (numbera test) (numberb test))))
(assert-equal result 1)))
;;;; Finally we can run our test suite and see how it performs.
-(textui-test-run (make-test-suite 'math-fixture))
+(textui-test-run (make-instance 'math-test-case))
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; ID: $Id: package.lisp,v 1.6 2003/08/04 16:13:58 kevin Exp $
+;;;; ID: $Id: package.lisp,v 1.7 2003/08/04 17:04:49 kevin Exp $
;;;; Purpose: Package definition for XLUnit
;;;;
-;;;; $Id: package.lisp,v 1.6 2003/08/04 16:13:58 kevin Exp $
+;;;; $Id: package.lisp,v 1.7 2003/08/04 17:04:49 kevin Exp $
;;;; *************************************************************************
(in-package #:cl-user)
;; test-case.lisp
#:test-case
#:def-test-method
- #:setup
- #:teardown
+ #:set-up
+ #:tear-down
+ #:run
#:run-test
#:make-test
#:summary
;; result.lisp
- #:test-result
- #:make-test-result
+ #:test-results
+ #:make-test-results
#:was-successful
)
(:documentation "This is the XLUnit Framework."))
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; ID: $Id: printer.lisp,v 1.3 2003/08/04 16:13:58 kevin Exp $
+;;;; ID: $Id: printer.lisp,v 1.4 2003/08/04 17:04:49 kevin Exp $
;;;; Purpose: Printer functions for XLUnit
;;;;
;;;; *************************************************************************
(incf i))
failures)))))
-#|
-(defun result-printer (result seconds stream)
- (format stream "~&Time: ~D~%~%" (coerce seconds 'float))
- (print-defects (errors result) "error" stream)
- (print-defects (failures result) "failure" stream)
- (if (was-successful result)
- (format stream "OK (~D tests)~%" (run-count result))
- (progn
- (format stream "~%FAILURES!!!~%")
- (format stream "Tests run: ~D, Failures: ~D, Errors: ~D~%"
- (run-count result) (failure-count result)
- (error-count 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))))))
-
-|#
-
(defgeneric summary (result))
-(defmethod summary ((result test-result))
+(defmethod summary ((result test-results))
(format nil "~D run, ~D erred, ~D failed"
- (run-count result) (error-count result) (failure-count result)))
+ (run-tests result) (error-count result) (failure-count result)))
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; ID: $Id: suite.lisp,v 1.4 2003/08/04 16:42:27 kevin Exp $
+;;;; ID: $Id: suite.lisp,v 1.5 2003/08/04 17:04:49 kevin Exp $
;;;; Purpose: Suite functions for XLUnit
;;;;
;;;; *************************************************************************
t)
(defmethod run-on-test ((suite test-suite)
- &key (result (make-instance 'test-result))
+ &key (result (make-instance 'test-results))
(handle-errors t))
(setup-testsuite-named (slot-value suite 'name))
(dolist (test (tests suite))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; ID: $Id: tcase.lisp,v 1.1 2003/08/04 17:04:49 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 ((ob test-case))
+ (run-on-test-results ob (make-instance 'test-results)))
+
+
+(defmethod run-on-test-results ((test test-case) result
+ &key (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-results))
+ (handle-errors t))
+ "Perform the test represented by the given test-case or test-suite.
+Returns a test-results 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))
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; ID: $Id: test-case.lisp,v 1.2 2003/08/04 16:42:27 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 ((ob test-case))
- (run-on-test-result ob (make-instance 'test-results)))
-
-
-
-(defmethod run-on-test-result ((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))
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; Id: $Id: tests.lisp,v 1.7 2003/08/04 16:13:58 kevin Exp $
+;;;; Id: $Id: tests.lisp,v 1.8 2003/08/04 17:04:50 kevin Exp $
;;;; Purpose: Test suite for XLUnit
;;;;
;;;; *************************************************************************
(run-test test)
(assert-equal (ws-log test) "setup test-method teardown ")))
-(defmethod test-result ((self test-case-test))
+(defmethod test-results ((self test-case-test))
(assert-equal "1 run, 0 erred, 0 failed"
(summary (run-test (make-test 'was-run 'test-method)))))
(defmethod test-suite ((self test-case-test))
(let ((suite (make-test-suite "TestSuite"))
- (result (make-test-result)))
+ (result (make-test-results)))
(add-test (make-test 'was-run 'test-method) suite)
(add-test (make-test 'was-run 'test-broken-method) suite)
(run-test suite :result result)
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; ID: $Id: textui.lisp,v 1.1 2003/08/04 16:13:58 kevin Exp $
+;;;; ID: $Id: textui.lisp,v 1.2 2003/08/04 17:04:50 kevin Exp $
;;;; Purpose: Text UI for Test Runner
;;;;
;;;; *************************************************************************
(result (make-instance 'test-results))
(start-time (get-internal-real-time)))
(add-listener result test-runner)
- (run-on-test-result ob result)
+ (run-on-test-results ob result)
(print-results test-runner result
(/ (- (get-internal-real-time) start-time)
internal-time-units-per-second))))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Aug 2003
;;;;
-;;;; $Id: xlunit.asd,v 1.3 2003/08/04 16:13:58 kevin Exp $
+;;;; $Id: xlunit.asd,v 1.4 2003/08/04 17:04:50 kevin Exp $
;;;; *************************************************************************
(defpackage #:xlunit-system (:use #:asdf #:cl))
:components
((:file "package")
(:file "assert")
- (:file "test-case")
+ (:file "tcase")
(:file "suite")
(:file "listener")
(:file "result")