From 6e195606e06173086a91616042adef3072633d92 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Mon, 4 Aug 2003 19:40:02 +0000 Subject: [PATCH] r5455: *** empty log message *** --- LICENSE | 4 +- Makefile | 9 +++++ README | 10 ++--- debian/changelog | 6 +++ debian/copyright | 4 +- example.lisp | 11 +++--- package.lisp | 9 +++-- printer.lisp | 10 +++-- result.lisp | 3 +- suite.lisp | 95 ++++++++++++++++++------------------------------ tcase.lisp | 76 +++++--------------------------------- tests.lisp | 84 ++++++++++++++++++++++-------------------- xlunit.asd | 4 +- 13 files changed, 135 insertions(+), 190 deletions(-) create mode 100644 Makefile diff --git a/LICENSE b/LICENSE index 8ba724e..dfdbaca 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,6 @@ -Copyright (c) 2003 Kevin M. Rosenberg +Copyright (c) 2003 Kevin M. Rosenberg +Copyright (C) 2002 Canoo Engineering AG + All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..0c6e148 --- /dev/null +++ b/Makefile @@ -0,0 +1,9 @@ +all: + + +.PHONY: clean +clean: + @rm -rf .bin + @rm -f *.ufsl *.fsl *.fas *.x86f *.sparcf *.fasl* *.lib + @rm -f *~ *.bak *.orig *.err \#*\# .#* + diff --git a/README b/README index a2079b7..7fceecb 100644 --- a/README +++ b/README @@ -1,10 +1,8 @@ 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). diff --git a/debian/changelog b/debian/changelog index b4dd854..b3fd5b8 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-xlunit (0.5.0-1) unstable; urgency=low + + * New usptream + + -- Kevin M. Rosenberg Mon, 4 Aug 2003 13:39:48 -0600 + cl-xlunit (0.2.0-1) unstable; urgency=low * New version diff --git a/debian/copyright b/debian/copyright index 85f2d57..cb106ad 100644 --- a/debian/copyright +++ b/debian/copyright @@ -8,7 +8,9 @@ Debian Maintainer: Kevin M. Rosenberg Upstream Copyright Statement ============================ -Copyright (c) 2003 Kevin M. Rosenberg +Copyright (c) 2003 Kevin M. Rosenberg +Copyright (C) 2002 Canoo Engineering AG + All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/example.lisp b/example.lisp index 837906b..4a89aec 100644 --- a/example.lisp +++ b/example.lisp @@ -2,7 +2,7 @@ ;;;; ************************************************************************* ;;;; 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 ;;;; ;;;; ************************************************************************* @@ -32,19 +32,20 @@ (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)) diff --git a/package.lisp b/package.lisp index ffaa50d..68562f2 100644 --- a/package.lisp +++ b/package.lisp @@ -2,10 +2,10 @@ ;;;; ************************************************************************* ;;;; 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) @@ -37,9 +37,12 @@ #: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 diff --git a/printer.lisp b/printer.lisp index c89bfff..3637ff4 100644 --- a/printer.lisp +++ b/printer.lisp @@ -2,7 +2,7 @@ ;;;; ************************************************************************* ;;;; 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 ;;;; ;;;; ************************************************************************* @@ -41,7 +41,8 @@ (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))))) @@ -53,8 +54,9 @@ (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))))) diff --git a/result.lisp b/result.lisp index 1b7fd35..eb49d0f 100644 --- a/result.lisp +++ b/result.lisp @@ -2,7 +2,7 @@ ;;;; ************************************************************************* ;;;; 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 ;;;; ;;;; ************************************************************************* @@ -35,7 +35,6 @@ res) (defmethod end-test ((tcase test) (res test-results)) - (incf (run-tests res)) (mapc (lambda (listener) (end-test listener tcase)) (listeners res)) res) diff --git a/suite.lisp b/suite.lisp index 85cfcc6..f2394ab 100644 --- a/suite.lisp +++ b/suite.lisp @@ -2,14 +2,14 @@ ;;;; ************************************************************************* ;;;; 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 @@ -19,65 +19,37 @@ `(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-'. @@ -111,12 +83,15 @@ This is used to dynamically generate a list of tests for a fixture." ; 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)))) diff --git a/tcase.lisp b/tcase.lisp index da0d8de..3d68142 100644 --- a/tcase.lisp +++ b/tcase.lisp @@ -2,7 +2,7 @@ ;;;; ************************************************************************* ;;;; 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 ;;;; ;;;; ************************************************************************* @@ -21,7 +21,7 @@ :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 @@ -56,9 +56,11 @@ 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 ((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)) @@ -73,7 +75,7 @@ that the setup method did for this instance.")) (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 @@ -85,63 +87,5 @@ that the setup method did for this instance.")) 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)) + + diff --git a/tests.lisp b/tests.lisp index 9b51919..3b848a4 100644 --- a/tests.lisp +++ b/tests.lisp @@ -2,7 +2,7 @@ ;;;; ************************************************************************* ;;;; 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 ;;;; ;;;; ************************************************************************* @@ -19,20 +19,22 @@ (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 @@ -40,50 +42,52 @@ (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"))) diff --git a/xlunit.asd b/xlunit.asd index 67c0fdd..c7f293a 100644 --- a/xlunit.asd +++ b/xlunit.asd @@ -7,7 +7,7 @@ ;;;; 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)) @@ -26,9 +26,9 @@ ((:file "package") (:file "assert") (:file "tcase") - (:file "suite") (:file "listener") (:file "result") + (:file "suite") (:file "textui") (:file "printer") )) -- 2.34.1