--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: assert.lisp
+;;;; Purpose: Assert functions for XLUnit
+;;;; Author: Kevin Rosenberg
+;;;;
+;;;; $Id: assert.lisp,v 1.1 2003/08/04 12:01:54 kevin Exp $
+;;;; *************************************************************************
+
+(in-package #:xlunit)
+
+
+;;; Assertions
+
+(define-condition test-failure-condition (simple-condition)
+ ((msg :initform nil :initarg :msg :accessor msg))
+ (:documentation "Base class for all test failures."))
+
+
+(defun failure (format-str &rest args)
+ "Signal a test failure and exit the test."
+ (signal 'test-failure-condition
+ :format-control format-str
+ :format-arguments args))
+
+(defmacro test-assert (test &optional msg)
+ `(unless ,test
+ (failure "Test assertion: ~s" ',test)))
+
+(defun assert-equal (v1 v2 &optional msg)
+ (unless (equal v1 v2)
+ (failure "Test equal: ~s ~s" v1 v2)))
+
+(defun assert-true (v &optional msg)
+ (unless v
+ (failure "Test true: ~s [~A]" v (if msg msg ""))))
+
+(defun assert-false (v &optional msg)
+ (when v
+ (failure "Test false ~A" (if msg msg ""))))
+
+cl-xlunit (0.2.0-1) unstable; urgency=low
+
+ * New version
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Mon, 4 Aug 2003 05:35:35 -0600
+
cl-xlunit (0.1.0-1) unstable; urgency=low
* Initial upload
dh_testroot
# dh_installdebconf
dh_installdocs
- dh_installexamples examples.lisp
+ dh_installexamples example.lisp
# dh_installmenu
# dh_installlogrotate
# dh_installemacsen
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: fixture.lisp
+;;;; Purpose: eXtreme Lisp Test Suite
+;;;; Authors: Kevin Rosenberg and Craig Brozefsky
+;;;;
+;;;; $Id: fixture.lisp,v 1.1 2003/08/04 12:01:54 kevin Exp $
+;;;; *************************************************************************
+
+(in-package #:xlunit)
+
+
+(defclass test-fixture ()
+ ((test-thunk
+ :initarg :test-thunk :reader test-thunk
+ :initform 'perform-test
+ :documentation
+ "A thunk or symbol which will be applied to this instance, a
+test-case, to perform that test-case. Defaults to 'perform-test")
+ (test-name
+ :initarg :test-name
+ :reader test-name
+ :documentation
+ "The name of this test-case, used in reports.")
+ (test-description
+ :initarg :description
+ :reader description
+ :documentation
+ "Short description of this test-case, uses in reports"))
+ (:documentation
+ "Base class for test-fixtures. Test-cases are instances of test-fixtures."))
+
+(defgeneric setup (test)
+ (:documentation
+ "Method called before performing a test, should set up the
+environment the test-case needs to operate in."))
+
+(defmethod setup ((test test-fixture))
+ t)
+
+(defgeneric teardown (test)
+ (:documentation
+ "Method called after performing a test. Should reverse everything
+that the setup method did for this instance."))
+
+(defmethod teardown ((test test-fixture))
+ t)
+
+
+(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-fixture)
+ &key (result (make-instance 'test-result))
+ (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."
+ (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-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))))
+ result)
+
+
+(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 (etypecase name
+ (symbol
+ (string-downcase (symbol-name 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))
+
;;;; Purpose: Package definition for XLTEST
;;;; Authors: Kevin Rosenberg and Craig Brozefsky
;;;;
-;;;; $Id: package.lisp,v 1.3 2003/08/04 09:50:33 kevin Exp $
+;;;; $Id: package.lisp,v 1.4 2003/08/04 12:01:54 kevin Exp $
;;;; *************************************************************************
(in-package #:cl-user)
(:nicknames #:xlunit #:xptest)
(:export
;;; Framework classes
+
+ ;; fixture
+ #:test-fixture
#:setup
#:teardown
- #:perform-test
- #:test-failure
- #:failure
#:run-test
#:make-test
+
+ ;; assert
+ #:assert-equal
+ #:assert-true
+ #:assert-false
+ #:test-assert
+ #:test-failure
+ #:failure
+
+ ;; suite.lisp
+ #:text-testrunner
#:make-test-suite
#:setup-testsuite-named
#:teardown-testsuite-named
#:test-named
#:remove-test
#:tests
- #:test-result
- #:report-result
- #:make-test-suite-for-fixture
- #:assert-equal
- #:assert-true
- #:assert-false
- #:test-assert
- #:test-fixture
- #:text-testrunner
+
+ ;; printer.lisp
#:summary
+
+ ;; result.lisp
+ #:test-result
+ #:make-test-result
+ #:was-successful
)
- (:documentation "This is the XP TestSuite Framework."))
+ (:documentation "This is the XLUnit Framework."))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: printer.lisp
+;;;; Purpose: Printer functions for XLUnit
+;;;; Authors: Kevin Rosenberg
+;;;;
+;;;; $Id: printer.lisp,v 1.1 2003/08/04 12:01:54 kevin Exp $
+;;;; *************************************************************************
+
+(in-package #:xlunit)
+
+
+(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 erred, ~D failed"
+ (test-count result) (length (test-errors result))
+ (length (test-failures result))))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: result.lisp
+;;;; Purpose: Result functions for XLUnit
+;;;; Authors: Kevin Rosenberg
+;;;;
+;;;; $Id: result.lisp,v 1.1 2003/08/04 12:01:54 kevin Exp $
+;;;; *************************************************************************
+
+(in-package #: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))
+ (:documentation "The result of applying a test"))
+
+
+(defun make-test-result ()
+ (make-instance 'test-result))
+
+(defclass test-failure ()
+ ((failed-test :initarg :failed-test :reader failed-test)
+ (thrown-condition :initarg :thrown-condition :reader thrown-condition)))
+
+(defmethod is-failure ((failure test-failure))
+ (typep (thrown-condition failure) 'test-failure-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 was-successful ((result test-result))
+ (and (null (test-failures result))
+ (null (test-errors result))))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: suite.lisp
+;;;; Purpose: Suite functions for XLUnit
+;;;; Authors: Kevin Rosenberg and Craig Brozefsky
+;;;;
+;;;; $Id: suite.lisp,v 1.1 2003/08/04 12:01:54 kevin Exp $
+;;;; *************************************************************************
+
+(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))
+ (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)
+ &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))
+ (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)))
+
+
+(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-suite) (suite test-suite))
+ (remhash (test-suite-name test) (tests-hash suite)))
+
+(defmethod test-named ((name string) (suite test-suite))
+ (gethash name (tests-hash suite)))
+
+
+;; Dynamic test suite
+
+(defun make-test-suite-for-fixture
+ (fixture &key
+ (name
+ (format nil "Automatic for ~A"
+ (if (slot-boundp fixture 'test-name)
+ (test-name fixture)
+ (type-of fixture))))
+ description)
+ (let ((suite (make-instance 'test-suite
+ :name name
+ :description description))
+ (fns (find-test-generic-functions fixture)))
+ (dolist (fn fns)
+ (make-test (class-name (class-of fixture)) fn
+ :test-suite suite))
+ suite))
+
+(defun find-test-generic-functions (instance)
+ "Return a list of symbols for generic functions specialized on the
+class of an instance and whose name begins with the string 'test-'.
+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)
+ (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)))
+
+
+;;; Test Runners
+
+(defmethod text-testrunner ((suite test-suite) &key (stream t)
+ (handle-errors t))
+ (let* ((start-time (get-internal-real-time))
+ (result (run-test suite :handle-errors handle-errors))
+ (seconds (/ (- (get-internal-real-time) start-time)
+ internal-time-units-per-second)))
+ (result-printer result seconds stream)))
+
;;;; Author: Kevin Rosenberg
;;;;
;;;; Put in public domain by Kevin Rosenberg
-;;;; $Id: tests.lisp,v 1.3 2003/08/04 09:50:33 kevin Exp $
+;;;; $Id: tests.lisp,v 1.4 2003/08/04 12:01:54 kevin Exp $
;;;; *************************************************************************
(defpackage #:xlunit-tests
(in-package #:xlunit-tests)
+
+;; Helper test fixture
(defclass was-run (test-fixture)
((log :accessor ws-log)))
-
(defmethod setup ((self was-run))
(setf (ws-log self) "setup "))
(defmethod test-error-method ((self was-run))
(error "Err"))
-(defclass test-case-test (test-fixture)
- ((result :accessor result)))
+;;; Main test fixture
-(defmethod setup ((self test-case-test))
- (setf (result self) (make-instance 'test-result)))
+(defclass test-case-test (test-fixture)
+ ())
(defmethod test-template-method ((self test-case-test))
(let ((test (make-test 'was-run 'test-method)))
- (run-test test (result self))
+ (run-test test)
(assert-equal (ws-log test) "setup test-method teardown ")))
(defmethod test-result ((self test-case-test))
- (let ((test (make-test 'was-run 'test-method)))
- (run-test test (result self))
- (assert-equal "1 run, 0 errored, 0 failed" (summary (result self)))))
+ (assert-equal "1 run, 0 erred, 0 failed"
+ (summary (run-test (make-test 'was-run 'test-method)))))
(defmethod test-thunk ((self test-case-test))
(let ((test (make-test 'was-run '"Test Failure"
(lambda (test)
(declare (ignore test))
(assert-equal 10 10)))))
- (run-test test (result self))
- (assert-equal "1 run, 0 errored, 0 failed"
- (summary (result self)))))
+ (assert-equal "1 run, 0 erred, 0 failed"
+ (summary (run-test test)))))
(defmethod test-failed-result ((self test-case-test))
- (let ((test (make-test 'was-run 'test-broken-method)))
- (run-test test (result self))
- (assert-equal "1 run, 0 errored, 1 failed"
- (summary (result self)))))
+ (assert-equal "1 run, 0 erred, 1 failed"
+ (summary (run-test
+ (make-test 'was-run 'test-broken-method)))))
(defmethod test-error-result ((self test-case-test))
- (let ((test (make-test 'was-run 'test-error-method)))
- (run-test test (result self))
- (assert-equal "1 run, 1 errored, 0 failed"
- (summary (result self)))))
-
+ (assert-equal "1 run, 1 erred, 0 failed"
+ (summary (run-test
+ (make-test 'was-run 'test-error-method)))))
+
(defmethod test-suite ((self test-case-test))
- (let ((suite (make-test-suite "TestSuite")))
+ (let ((suite (make-test-suite "TestSuite"))
+ (result (make-test-result)))
(add-test (make-test 'was-run 'test-method) suite)
(add-test (make-test 'was-run 'test-broken-method) suite)
- (run-test suite (result self)))
- (assert-equal "2 run, 0 errored, 1 failed"
- (summary (result self))))
+ (run-test suite :result result)
+ (assert-equal "2 run, 0 erred, 1 failed" (summary result))))
(defmethod test-dynamic-suite ((self test-case-test))
- (let ((suite (make-test-suite 'was-run)))
- (run-test suite (result self)))
- (assert-equal "3 run, 1 errored, 1 failed"
- (summary (result self))))
+ (assert-equal "3 run, 1 erred, 1 failed"
+ (summary (run-test (make-test-suite 'was-run)))))
-(text-testrunner (make-test-suite 'test-case-test))
+(text-testrunner (make-test-suite 'test-case-test) :handle-errors nil)
+(defun do-tests ()
+ (or (was-successful
+ (run-test (make-test-suite 'test-case-test)))
+ (error "Failed tests")))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Aug 2003
;;;;
-;;;; $Id: xlunit.asd,v 1.1 2003/08/04 09:51:36 kevin Exp $
+;;;; $Id: xlunit.asd,v 1.2 2003/08/04 12:01:54 kevin Exp $
;;;; *************************************************************************
(defpackage #:xlunit-system (:use #:asdf #:cl))
:name "xlunit"
:author "Kevin Rosenberg based on work by Craig Brozensky"
:maintainer "Kevin M. Rosenberg <kmr@debian.org>"
- :licence "Public domain"
+ :licence "BSD"
:description "Extreme Lisp Testing Suite"
- :long-description "The XLUNIT package is toolkit for building test suites based on the XPTEST package by Craig Brozensky."
+ :long-description "The XLUnit package is toolkit for building test suites. It is based on the XPTest package by Craig Brozensky and the JUnit package by Kent Beck."
+ :serial t
:components
((:file "package")
- (:file "src" :depends-on ("package"))))
+ (:file "assert")
+ (:file "fixture")
+ (:file "suite")
+ (:file "result")
+ (:file "printer")
+ ))
(defmethod perform ((o test-op) (c (eql (find-system 'xlunit))))
- (oos 'load-op 'xlunit-tests)
- (oos 'test-op 'xlunit-tests))
+ (oos 'load-op 'xlunit-tests :force t)
+ (oos 'test-op 'xlunit-tests :force t))
(defsystem xlunit-tests
- :depends-on (xlunit)
- :components ((:file "tests")))
+ :depends-on (xlunit)
+ :components ((:file "tests")))
(defmethod perform ((o test-op) (c (eql (find-system 'xlunit-tests))))
- (or (funcall (intern (symbol-name #:do-tests)
- (find-package #:xlunit-tests)))
+ (or (funcall (intern (symbol-name '#:do-tests)
+ (find-package '#:xlunit-tests)))
(error "test-op failed")))
projects / xlunit.git / commitdiff