-Copyright (c) 2003 Kevin M. Rosenberg
+Copyright (c) 2003 Kevin M. Rosenberg <kevin@rosenberg.net>
+Copyright (C) 2002 Canoo Engineering AG <sandro.pedrazzini_at_canoo.com>
+
All rights reserved.
Redistribution and use in source and binary forms, with or without
--- /dev/null
+all:
+
+
+.PHONY: clean
+clean:
+ @rm -rf .bin
+ @rm -f *.ufsl *.fsl *.fas *.x86f *.sparcf *.fasl* *.lib
+ @rm -f *~ *.bak *.orig *.err \#*\# .#*
+
XLUnit provides a unit testing package for Common Lisp. It it based
-on the XPTest package by OnShore development, but is rewritten to be
-closer in usage to the JUnit package.
-
-XLUnit it is designed to be used with significantly less overhead on
-the part of the test author compared to XPTest. Most powerfully,
-XLUnit can create dynamic test suites based on defined methods.
+on the 3 similar packages:
+ JUnit by Kent Beck
+ XPTest package by OnShore development
+ CLOS-unit by Sandro Pedrazzini
XLUnit comes with its own test suite (tests.lisp) along with an
example file (example.lisp).
+cl-xlunit (0.5.0-1) unstable; urgency=low
+
+ * New usptream
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Mon, 4 Aug 2003 13:39:48 -0600
+
cl-xlunit (0.2.0-1) unstable; urgency=low
* New version
Upstream Copyright Statement
============================
-Copyright (c) 2003 Kevin M. Rosenberg
+Copyright (c) 2003 Kevin M. Rosenberg <kevin@rosenberg.net>
+Copyright (C) 2002 Canoo Engineering AG <sandro.pedrazzini_at_canoo.com>
+
All rights reserved.
Redistribution and use in source and binary forms, with or without
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; ID: $Id: example.lisp,v 1.6 2003/08/04 17:04:49 kevin Exp $
+;;;; ID: $Id: example.lisp,v 1.7 2003/08/04 19:31:34 kevin Exp $
;;;; Purpose: Example file for XLUnit
;;;;
;;;; *************************************************************************
(setf (numbera tcase) 2)
(setf (numberb tcase) 3))
-(def-test-method test-addition ((test math-test-case))
+
+(def-test-method (test-addition test math-test-case :run nil)
(let ((result (+ (numbera test) (numberb test))))
(assert-true (= result 5))))
-(def-test-method test-subtraction ((test math-test-case))
+(def-test-method (test-subtraction test math-test-case :run nil)
(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-test-case))
+(def-test-method (test-subtraction-2 test math-test-case :run nil)
(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-instance 'math-test-case))
+(textui-test-run (get-suite math-test-case))
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; ID: $Id: package.lisp,v 1.7 2003/08/04 17:04:49 kevin Exp $
+;;;; ID: $Id: package.lisp,v 1.8 2003/08/04 19:31:34 kevin Exp $
;;;; Purpose: Package definition for XLUnit
;;;;
-;;;; $Id: package.lisp,v 1.7 2003/08/04 17:04:49 kevin Exp $
+;;;; $Id: package.lisp,v 1.8 2003/08/04 19:31:34 kevin Exp $
;;;; *************************************************************************
(in-package #:cl-user)
#:setup-testsuite-named
#:teardown-testsuite-named
#:add-test
- #:test-named
+ #:named-test
#:remove-test
#:tests
+ #:get-suite
+ #:test-suite
+ #:run-on-test-results
;; printer.lisp
#:summary
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; ID: $Id: printer.lisp,v 1.4 2003/08/04 17:04:49 kevin Exp $
+;;;; ID: $Id: printer.lisp,v 1.5 2003/08/04 19:31:34 kevin Exp $
;;;; Purpose: Printer functions for XLUnit
;;;;
;;;; *************************************************************************
(let ((i 1))
(mapc #'(lambda (single-error)
(format (ostream ob) "~a) ~a: ~a~%" i
- (name (car single-error)) (cdr single-error))
+ (name (failed-test single-error))
+ (thrown-condition single-error))
(incf i))
errors)))))
(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)) ""))
+ (format (ostream ob) "~a) ~a: ~a~%" i
+ (name (failed-test single-failure))
+ (or (message (thrown-condition single-failure)) ""))
(incf i))
failures)))))
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; ID: $Id: result.lisp,v 1.5 2003/08/04 16:42:27 kevin Exp $
+;;;; ID: $Id: result.lisp,v 1.6 2003/08/04 19:31:34 kevin Exp $
;;;; Purpose: Result functions for XLUnit
;;;;
;;;; *************************************************************************
res)
(defmethod end-test ((tcase test) (res test-results))
- (incf (run-tests res))
(mapc (lambda (listener) (end-test listener tcase)) (listeners res))
res)
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; ID: $Id: suite.lisp,v 1.5 2003/08/04 17:04:49 kevin Exp $
+;;;; ID: $Id: suite.lisp,v 1.6 2003/08/04 19:31:34 kevin Exp $
;;;; Purpose: Suite functions for XLUnit
;;;;
;;;; *************************************************************************
(in-package #:xlunit)
-(defclass test-suite ()
+(defclass test-suite (test)
((name :initform "" :initarg :name :reader test-suite-name)
(tests :initarg :tests :accessor tests :initform nil)
(description :initarg :description :reader description
`(suite (make-instance ',class-name)))
-(defmethod setup-testsuite-named (name)
- (declare (ignore name))
- t)
-
-(defmethod teardown-testsuite-named (name)
- (declare (ignore name))
- t)
-
-(defmethod run-on-test ((suite test-suite)
- &key (result (make-instance 'test-results))
- (handle-errors t))
- (setup-testsuite-named (slot-value suite 'name))
- (dolist (test (tests suite))
- (run-on-test test :result result :handle-errors handle-errors))
- (teardown-testsuite-named (slot-value suite 'name))
- result)
-
-
(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)))
+ (remove-test new-test ob)
(setf (tests ob) (append (tests ob) (list new-test))))
-#|
-(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 named ((name string) (suite test-suite))
- (gethash name (tests-hash suite)))
-|#
+(defmethod run-on-test-results ((ob test-suite) (result test-results)
+ &key (handle-errors t))
+ (mapc #'(lambda (composite) ;;test-case or suite
+ (run-on-test-results composite result
+ :handle-errors handle-errors))
+ (tests ob)))
+
+(defmethod named-test (name (suite test-suite))
+ (some (lambda (test-or-suite)
+ (when (and (typep test-or-suite 'test-case)
+ (equal name (name test-or-suite)))
+ test-or-suite))
+ (tests suite)))
+
+(defmethod remove-test ((test test) (suite test-suite))
+ (setf (tests suite)
+ (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 test)))))
+ (tests suite))))
;; Dynamic test suite
-(defun make-test-suite-for-fixture
- (fixture &key
- (name
- (format nil "Automatic for ~A"
- (if (slot-boundp fixture 'name)
- (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-'.
; 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)
+(defmacro def-test-method ((method-name instance-name class-name
+ &key (run t))
+ &body method-body)
+ `(let ((,instance-name
+ (make-instance ',class-name
:name ',method-name)))
- (setf (method-body ,(caar class-name))
+ (setf (method-body ,instance-name)
#'(lambda() ,@method-body))
- (add-test (suite ,(caar class-name)) ,(caar class-name))
- (textui-test-run ,(caar class-name))))
+ (add-test (suite ,instance-name) ,instance-name)
+ (when ,run
+ (textui-test-run ,instance-name))))
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; ID: $Id: tcase.lisp,v 1.1 2003/08/04 17:04:49 kevin Exp $
+;;;; ID: $Id: tcase.lisp,v 1.2 2003/08/04 19:31:34 kevin Exp $
;;;; Purpose: Test fixtures for XLUnit
;;;;
;;;; *************************************************************************
:documentation
"A function designator which will be applied to this instance
to perform that test-case.")
- (name :initarg :name :reader name
+ (name :initarg :name :reader name :initform ""
:documentation "The name of this test-case, used in reports.")
(description :initarg :description :reader description
:documentation
(defmethod tear-down ((test test-case))
)
-(defmethod run ((ob test-case))
- (run-on-test-results ob (make-instance 'test-results)))
-
+(defmethod run ((ob test) &key (handle-errors t))
+ "Generalized to work on test-case and test-suites"
+ (let ((res (make-test-results)))
+ (run-on-test-results ob res :handle-errors t)
+ res))
(defmethod run-on-test-results ((test test-case) result
&key (handle-errors t))
(tear-down test)))
(defmethod run-test ((test test-case))
- (funcall (method-body test)))
+ (funcall (method-body test)))
(defmethod run-protected ((test test-case) res &key (handle-errors t))
(handler-case
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))
+
+
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; Id: $Id: tests.lisp,v 1.8 2003/08/04 17:04:50 kevin Exp $
+;;;; Id: $Id: tests.lisp,v 1.9 2003/08/04 19:31:34 kevin Exp $
;;;; Purpose: Test suite for XLUnit
;;;;
;;;; *************************************************************************
(defclass was-run (test-case)
((log :accessor ws-log)))
-(defmethod setup ((self was-run))
- (setf (ws-log self) "setup "))
+(defmethod set-up ((self was-run))
+ (setf (ws-log self) "setup "))
-(defmethod teardown ((self was-run))
- (setf (ws-log self) (concatenate 'string (ws-log self) "teardown ")))
+(defmethod tear-down ((self was-run))
+ (setf (ws-log self)
+ (concatenate 'string (ws-log self) "teardown ")))
-(defmethod test-method ((self was-run))
- (setf (ws-log self) (concatenate 'string (ws-log self) "test-method ")))
+(def-test-method (test-method self was-run :run nil)
+ (setf (ws-log self)
+ (concatenate 'string (ws-log self) "test-method ")))
-(defmethod test-broken-method ((self was-run))
- (assert-equal pi (/ 22 7)))
+(def-test-method (test-broken-method self was-run :run nil)
+ (assert-equal pi (/ 22 7)))
-(defmethod test-error-method ((self was-run))
- (error "Err"))
+(def-test-method (test-error-method self was-run :run nil)
+ (error "Err"))
;;; Main test fixture
(defclass test-case-test (test-case)
())
-(defmethod test-template-method ((self test-case-test))
- (let ((test (make-test 'was-run 'test-method)))
- (run-test test)
+
+(def-test-method (test-template-method self test-case-test :run nil)
+ (let ((test (named-test 'test-method (get-suite was-run))))
+ (run test)
(assert-equal (ws-log test) "setup test-method teardown ")))
-(defmethod test-results ((self test-case-test))
+(def-test-method (test-results self test-case-test :run nil)
(assert-equal "1 run, 0 erred, 0 failed"
- (summary (run-test (make-test 'was-run 'test-method)))))
-
-(defmethod test-fn ((self test-case-test))
- (let ((test (make-test 'was-run '"Test Failure"
- :test-fn
- (lambda (test)
- (declare (ignore test))
- (assert-equal 10 10)))))
+ (summary (run (named-test 'test-method (get-suite was-run))))))
+
+(def-test-method (test-fn self test-case-test :run nil)
+ (let ((test (make-instance 'test-case :name 'test-fn
+ :method-body
+ (lambda ()
+ (declare (ignore test))
+ (assert-equal 10 10)))))
(assert-equal "1 run, 0 erred, 0 failed"
- (summary (run-test test)))))
+ (summary (run test)))))
-(defmethod test-failed-result ((self test-case-test))
+(def-test-method (test-failed-result self test-case-test :run nil)
(assert-equal "1 run, 0 erred, 1 failed"
(summary (run-test
- (make-test 'was-run 'test-broken-method)))))
+ (named-test 'test-broken-method (get-suite was-run))))))
-(defmethod test-error-result ((self test-case-test))
- (assert-equal "1 run, 1 erred, 0 failed"
- (summary (run-test
- (make-test 'was-run 'test-error-method)))))
+(def-test-method (test-error-result self test-case-test :run nil)
+ (assert-equal "1 run, 1 erred, 0 failed"
+ (summary (run-test
+ (named-test 'test-error-method
+ (get-suite was-run))))))
-(defmethod test-suite ((self test-case-test))
- (let ((suite (make-test-suite "TestSuite"))
+(def-test-method (test-suite self test-case-test :run nil)
+ (let ((suite (make-instance 'test-suite))
(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)
+ (add-test suite (named-test 'test-method (get-suite was-run)))
+ (add-test suite (named-test 'test-broken-method (get-suite was-run)))
+ (run-on-test-results suite result)
(assert-equal "2 run, 0 erred, 1 failed" (summary result))))
-(defmethod test-dynamic-suite ((self test-case-test))
+(def-test-method (test-dynamic-suite self test-case-test :run nil)
(assert-equal "3 run, 1 erred, 1 failed"
- (summary (run-test (make-test-suite 'was-run)))))
+ (summary (run (get-suite was-run)))))
+
-(textui-test-run (make-test-suite 'test-case-test) :handle-errors nil)
+(textui-test-run (get-suite test-case-test))
(defun do-tests ()
- (or (was-successful
- (run-test (make-test-suite 'test-case-test)))
+ (or (was-successful (run (get-suite test-case-test)))
(error "Failed tests")))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Aug 2003
;;;;
-;;;; $Id: xlunit.asd,v 1.4 2003/08/04 17:04:50 kevin Exp $
+;;;; $Id: xlunit.asd,v 1.5 2003/08/04 19:31:34 kevin Exp $
;;;; *************************************************************************
(defpackage #:xlunit-system (:use #:asdf #:cl))
((:file "package")
(:file "assert")
(:file "tcase")
- (:file "suite")
(:file "listener")
(:file "result")
+ (:file "suite")
(:file "textui")
(:file "printer")
))