From: Kevin M. Rosenberg Date: Mon, 4 Aug 2003 09:46:44 +0000 (+0000) Subject: r5446: *** empty log message *** X-Git-Tag: debian-0.6.2-2~28 X-Git-Url: http://git.kpe.io/?p=xlunit.git;a=commitdiff_plain;h=c7bc011f355411986f238987a4f97c93f66818dc r5446: *** empty log message *** --- diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..8ba724e --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2003 Kevin M. Rosenberg +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of the contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/README b/README new file mode 100644 index 0000000..a2079b7 --- /dev/null +++ b/README @@ -0,0 +1,12 @@ +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. + +XLUnit comes with its own test suite (tests.lisp) along with an +example file (example.lisp). + + diff --git a/debian/changelog b/debian/changelog new file mode 100644 index 0000000..84ff91b --- /dev/null +++ b/debian/changelog @@ -0,0 +1,5 @@ +cl-xlunut (0.1.0-1) unstable; urgency=low + + * Initial upload + + -- Kevin M. Rosenberg Mon, 4 Aug 2003 03:40:37 -0600 diff --git a/debian/compat b/debian/compat new file mode 100644 index 0000000..b8626c4 --- /dev/null +++ b/debian/compat @@ -0,0 +1 @@ +4 diff --git a/debian/control b/debian/control new file mode 100644 index 0000000..0a3ad62 --- /dev/null +++ b/debian/control @@ -0,0 +1,16 @@ +Source: cl-xlunit +Section: devel +Priority: optional +Maintainer: Kevin M. Rosenberg +Build-Depends-Indep: debhelper (>> 4.0.0) +Standards-Version: 3.6.0 + +Package: cl-xlunit +Architecture: all +Depends: ${shlibs:Depends}, common-lisp-controller (>= 3.37) +Description: Common Lisp eXtreme Lisp Unit Testing Package + 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. Also, it is + designed to be used with significantly less overhead on the + part of the test author compared to XPTest. diff --git a/debian/copyright b/debian/copyright new file mode 100644 index 0000000..85f2d57 --- /dev/null +++ b/debian/copyright @@ -0,0 +1,36 @@ +Debian Copyright Section +======================== + +Upstream Source URL: http://files.b9.com/xlunit/ +Upstream Authors: Kevin M. Rosenberg +Debian Maintainer: Kevin M. Rosenberg + + +Upstream Copyright Statement +============================ +Copyright (c) 2003 Kevin M. Rosenberg +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of the contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/debian/postinst b/debian/postinst new file mode 100644 index 0000000..32f3d9d --- /dev/null +++ b/debian/postinst @@ -0,0 +1,47 @@ +#! /bin/sh +set -e + +LISP_PKG=xlunit + +# summary of how this script can be called: +# * `configure' +# * `abort-upgrade' +# * `abort-remove' `in-favour' +# +# * `abort-deconfigure' `in-favour' +# `removing' +# +# for details, see http://www.debian.org/doc/debian-policy/ or +# the debian-policy package +# +# quoting from the policy: +# Any necessary prompting should almost always be confined to the +# post-installation script, and should be protected with a conditional +# so that unnecessary prompting doesn't happen if a package's +# installation fails and the `postinst' is called with `abort-upgrade', +# `abort-remove' or `abort-deconfigure'. + +case "$1" in + configure) + /usr/sbin/register-common-lisp-source ${LISP_PKG} + + ;; + + abort-upgrade|abort-remove|abort-deconfigure) + + ;; + + *) + echo "postinst called with unknown argument \`$1'" >&2 + exit 1 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 + + diff --git a/debian/prerm b/debian/prerm new file mode 100644 index 0000000..2603546 --- /dev/null +++ b/debian/prerm @@ -0,0 +1,37 @@ +#! /bin/sh +set -e + +LISP_PKG=xlunit + +# summary of how this script can be called: +# * `remove' +# * `upgrade' +# * `failed-upgrade' +# * `remove' `in-favour' +# * `deconfigure' `in-favour' +# `removing' +# +# for details, see http://www.debian.org/doc/debian-policy/ or +# the debian-policy package + + +case "$1" in + remove|upgrade|deconfigure) + /usr/sbin/unregister-common-lisp-source ${LISP_PKG} + ;; + failed-upgrade) + ;; + *) + echo "prerm called with unknown argument \`$1'" >&2 + exit 1 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 + + diff --git a/debian/rules b/debian/rules new file mode 100755 index 0000000..3e2f340 --- /dev/null +++ b/debian/rules @@ -0,0 +1,80 @@ +#!/usr/bin/make -f + +pkg := xlunit +debpkg := cl-xlunit + + +clc-source := usr/share/common-lisp/source +clc-systems := usr/share/common-lisp/systems +clc-xlunit := $(clc-source)/$(pkg) + +doc-dir := usr/share/doc/$(debpkg) + + +configure: configure-stamp +configure-stamp: + dh_testdir + # Add here commands to configure the package. + touch configure-stamp + + +build: build-stamp + +build-stamp: configure-stamp + dh_testdir + # Add here commands to compile the package. + touch build-stamp + +clean: + dh_testdir + dh_testroot + rm -f build-stamp configure-stamp + # Add here commands to clean up after the build process. + rm -f debian/cl-xlunit.postinst.* debian/cl-xlunit.prerm.* + dh_clean + +install: build + dh_testdir + dh_testroot + dh_clean -k + # Add here commands to install the package into debian/xlunit. + dh_installdirs $(clc-systems) $(clc-xlunit) $(doc-dir) + dh_install xlunit.asd $(shell echo *.lisp) $(clc-xlunit) + dh_link $(clc-xlunit)/xlunit.asd $(clc-systems)/xlunit.asd + +# Build architecture-independent files here. +binary-indep: build install + + +# Build architecture-dependent files here. +binary-arch: build install + dh_testdir + dh_testroot +# dh_installdebconf + dh_installdocs + dh_installexamples examples.lisp +# dh_installmenu +# dh_installlogrotate +# dh_installemacsen +# dh_installpam +# dh_installmime +# dh_installinit +# dh_installcron +# dh_installman +# dh_installinfo +# dh_undocumented + dh_installchangelogs + dh_strip + dh_compress + dh_fixperms +# dh_makeshlibs + dh_installdeb +# dh_perl + dh_shlibdeps + dh_gencontrol + dh_md5sums + dh_builddeb + +binary: binary-indep binary-arch +.PHONY: build clean binary-indep binary-arch binary install configure + diff --git a/debian/upload.sh b/debian/upload.sh new file mode 100755 index 0000000..3653713 --- /dev/null +++ b/debian/upload.sh @@ -0,0 +1,3 @@ +#!/bin/bash -e + +dup xlunit -Uftp.med-info.com -D/home/ftp/xlunit -C"/home/kevin/bin/remove-old-versions xlunit latest" -su $* diff --git a/example.lisp b/example.lisp index 4f1fcb9..ce53451 100644 --- a/example.lisp +++ b/example.lisp @@ -6,14 +6,12 @@ ;;;; Purpose: Example file for XLTest ;;;; Authors: Kevin Rosenberg and Craig Brozefsky ;;;; -;;;; Put in public domain by Kevin Rosenberg and onShore, Inc -;;;; $Id: example.lisp,v 1.1 2003/08/04 06:00:01 kevin Exp $ +;;;; $Id: example.lisp,v 1.2 2003/08/04 09:46:44 kevin Exp $ ;;;; ************************************************************************* (defpackage #:xltest-example (:use #:cl #:xltest) - (:export - #:math-test-suite)) + (:export #:math-test-suite)) (in-package #:xltest-example) @@ -22,11 +20,9 @@ ;;; 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. -(def-test-fixture math-fixture () - ((numbera - :accessor numbera) - (numberb - :accessor numberb)) +(defclass math-fixture (test-fixture) + ((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 @@ -73,36 +69,6 @@ (let ((result (- (numbera test) (numberb test)))) (assert-equal result 1))) - -;;; Now we can create a test-suite. A test-suite contains a group of -;;; test-cases (instances of test-fixture) and/or other test-suites. -;;; We can specify which tests are in a test-suite when we define the -;;; test-suite, or we can add them later. See the documentation and -;;; argument list for make-test-case for details on how to specify a -;;; test-case. - -(defparameter *manual-math-test-suite* - (make-test-suite - "Math Test Suite" - "Simple test suite for arithmetic operators." - '(("Addition Test" math-fixture - :test-thunk test-addition - :description "A simple test of the + operator") - ("Subtraction Test" math-fixture - :test-thunk test-subtraction - :description "A simple test of the - operator")))) - -(add-test (make-test-case "Subtraction Test 2" 'math-fixture - :test-thunk 'test-subtraction-2 - :description "A broken substraction test, should fail.") - *manual-math-test-suite*) - - -(defparameter *dynamic-math-test-suite* (make-test-suite 'math-fixture)) - ;;;; Finally we can run our test suite and see how it performs. -(report-result (run-test *manual-math-test-suite* - :handle-errors t) :verbose t) +(text-testrunner (make-test-suite 'math-fixture)) -(report-result (run-test *dynamic-math-test-suite* - :handle-errors t) :verbose nil) diff --git a/package.lisp b/package.lisp index 049793c..e935fda 100644 --- a/package.lisp +++ b/package.lisp @@ -7,7 +7,7 @@ ;;;; Authors: Kevin Rosenberg and Craig Brozefsky ;;;; ;;;; Put in public domain by Kevin Rosenberg and onShore, Inc -;;;; $Id: package.lisp,v 1.1 2003/08/04 06:00:01 kevin Exp $ +;;;; $Id: package.lisp,v 1.2 2003/08/04 09:46:44 kevin Exp $ ;;;; ************************************************************************* (in-package #:cl-user) @@ -23,8 +23,7 @@ #:test-failure #:failure #:run-test - #:def-test-fixture - #:make-test-case + #:make-test #:make-test-suite #:setup-testsuite-named #:teardown-testsuite-named @@ -39,6 +38,9 @@ #:assert-true #:assert-false #:test-assert + #:test-fixture + #:text-testrunner + #:summary ) (:documentation "This is the XP TestSuite Framework.")) diff --git a/src.lisp b/src.lisp index 20c3f1f..a809258 100644 --- a/src.lisp +++ b/src.lisp @@ -7,7 +7,7 @@ ;;;; Authors: Kevin Rosenberg and Craig Brozefsky ;;;; ;;;; Put in public domain by Kevin Rosenberg and onShore, Inc -;;;; $Id: src.lisp,v 1.1 2003/08/04 06:00:01 kevin Exp $ +;;;; $Id: src.lisp,v 1.2 2003/08/04 09:46:44 kevin Exp $ ;;;; ************************************************************************* (in-package #:xltest) @@ -43,30 +43,45 @@ environment the test-case needs to operate in." setup method did for this instance." t) -(define-condition test-failure (simple-condition) () +(define-condition test-failure-condition (simple-condition) + () (:documentation "Base class for all test failures.")) +(defclass test-failure () + ((failed-test :initarg :failed-test :reader failed-test) + (thrown-condition :initarg :thrown-condition :reader thrown-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 is-failure ((failure test-failure)) + (typep (thrown-condition failure) 'test-failure-condition)) + (defun failure (format-str &rest args) "Signal a test failure and exit the test." - (signal 'test-failure + (signal 'test-failure-condition :format-control format-str :format-arguments args)) -(defmacro test-assert (test) +(defmacro test-assert (test &optional msg) `(unless ,test - (failure "Test assertion failed: ~s" ',test))) + (failure "Test assertion: ~s" ',test))) -(defun assert-equal (v1 v2) +(defun assert-equal (v1 v2 &optional msg) (unless (equal v1 v2) - (failure "Test equals failed: ~s ~s" v1 v2))) + (failure "Test equal: ~s ~s" v1 v2))) -(defun assert-true (v) +(defun assert-true (v &optional msg) (unless v - (failure "Test true failed: ~s" v))) + (failure "Test true: ~s [~A]" v (if msg msg "")))) -(defun assert-false (v) +(defun assert-false (v &optional msg) (when v - (failure "Test false failed"))) + (failure "Test false ~A" (if msg msg "")))) (defmethod perform-test ((test test-fixture)) @@ -87,59 +102,88 @@ setup method did for this instance." ,cleanup) (progn ,protected ,cleanup))) -(defmethod run-test ((test test-fixture) &key (handle-errors t)) +(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")) + +(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) (result test-result) + &key (handle-errors t)) + (setup-testsuite-named (slot-value suite 'name)) + (dolist (test (tests suite)) + (run-test test result :handle-errors handle-errors)) + (teardown-testsuite-named (slot-value suite 'name)) + (values)) + +(defmethod run-test ((test test-fixture) result &key (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." - (let ((failures ()) - (errs ())) + (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) - (setf failures (cons res failures)))) - (test-failure (failure) - (setf failures (cons failure failures))) - (t (err) - (setf errs (cons err errs)))) - (handler-case-if handle-errors - (teardown test) - (t (err) - (setf errs (cons err errs))))) - (make-instance 'test-result - :test test - :failures failures - :errors errs))) - -(defmacro def-test-fixture (name supers slotdefs &rest class-options) - "Define a new test-fixture class. Works just like defclass, but -ensure that test-fixture is a super." - `(defclass ,name ,(append supers (list 'test-fixture)) - ,slotdefs ,@class-options)) - -(defun make-test-case (name fixture &key - (test-thunk 'perform-test) - (test-suite nil) - (description nil)) + (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)))) + (values)) + + +(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 name - :test-thunk test-thunk + :test-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)) -(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 tests ((suite test-suite)) (let ((tlist nil)) (maphash #'(lambda (k v) @@ -158,7 +202,7 @@ instance" (let ((suite (make-instance 'test-suite :name name-or-fixture :description description))) (dolist (testspec testspecs) - (add-test (apply #'make-test-case testspec) suite)) + (add-test (apply #'make-test testspec) suite)) suite)))) (defmethod add-test ((test test-fixture) (suite test-suite)) @@ -176,81 +220,51 @@ instance" (defmethod test-named ((name string) (suite test-suite)) (gethash name (tests-hash suite))) -(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 (handle-errors t)) - (let ((start-time (get-internal-real-time))) - (setup-testsuite-named (slot-value suite 'name)) - (let ((res (mapcar (lambda (test) (run-test test - :handle-errors handle-errors)) - (tests suite)))) - (teardown-testsuite-named (slot-value suite 'name)) - (make-instance 'suite-results - :suite suite - :test-results res - :start-time start-time - :stop-time (get-internal-real-time))))) - - -(defclass test-result () - ((test :initarg :test :reader result-test) - (failures :initarg :failures :reader test-failures :initform nil) - (errors :initarg :errors :reader test-errors :initform nil)) - (:documentation "The result of applying a test")) - -(defclass suite-results () - ((suite :initarg :suite :reader suite) - (start-time :initarg :start-time :reader start-time) - (stop-time :initarg :stop-time :reader stop-time) - (test-results :initarg :test-results :reader test-results)) - (:documentation "Results of running a suite")) - - -(defmethod report-result ((result test-result) &key (stream t) - (verbose nil)) - "Print out a test-result object for a report to STREAM, default to -standard-output. If VERBOSE is non-nil then will produce a lengthy -and informative report, otherwise just prints wether the test passed -or failed or errored out." - (when (or verbose (test-failures result) (test-errors result)) - (when verbose - (format stream - "------------------------------------------------------~%")) - (format stream "~A~A" - (test-name (result-test result)) - (cond - ((test-failures result) ":") - ((test-errors result) ":") - (t ": Passed"))) - (when (test-failures result) - (format stream " Failures: ~{~A~^; ~}" (test-failures result))) - (when (test-errors result) - (format stream " Errors: ~{~A~^; ~}" (test-errors result))) - (fresh-line stream) - (when verbose - (when (description (result-test result)) - (format stream "Description: ~A~%" - (description (result-test result))))))) - -(defmethod report-result ((results suite-results) &key (stream t) - (verbose nil)) - (format stream "~&.............~%") - (format stream "~&Time: ~D~%" - (float - (/ (- (stop-time results) (start-time results)) - internal-time-units-per-second))) - (if (some (lambda (res) (or (test-failures res) (test-errors res))) - (test-results results)) - (dolist (foo (test-results results)) - (report-result foo :stream stream :verbose verbose)) - (format stream "~&OK (~D tests)~%" (length (test-results results))))) - +(defmethod was-successful ((result test-result)) + (and (null (test-failures result)) + (null (test-errors result)))) + +(defmethod text-testrunner ((suite test-suite) &key (stream t) + (handle-errors t)) + (let ((result (make-instance 'test-result)) + (start-time (get-internal-real-time))) + (run-test suite result :handle-errors handle-errors) + (let ((seconds (/ (- (get-internal-real-time) start-time) + internal-time-units-per-second))) + (result-printer result seconds stream)))) + +(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 errored, ~D failed" + (test-count result) (length (test-errors result)) + (length (test-failures result)))) ;;; Dynamic test suite addition by Kevin Rosenberg 8/2003 @@ -267,9 +281,8 @@ or failed or errored out." :description description)) (fns (find-test-generic-functions fixture))) (dolist (fn fns) - (make-test-case fn (class-name (class-of fixture)) - :test-thunk fn - :test-suite suite)) + (make-test (class-name (class-of fixture)) fn + :test-suite suite)) suite)) (defun find-test-generic-functions (instance) @@ -279,21 +292,14 @@ 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) - (multiple-value-bind (sym status) - (find-symbol (symbol-name s) package) - (when (and (or (eq status :external) - (eq status :internal)) - (fboundp sym) - (eq (symbol-package sym) package) - (> (length (symbol-name sym)) 5) - (string-equal "test-" (subseq (symbol-name sym) 0 5)) - (typep (symbol-function sym) 'generic-function) - (plusp - (length - (compute-applicable-methods - (ensure-generic-function sym) - (list instance))))) - (push sym res)))) + (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))) diff --git a/tests.lisp b/tests.lisp index 9f2302a..9e4d4b7 100644 --- a/tests.lisp +++ b/tests.lisp @@ -7,7 +7,7 @@ ;;;; Author: Kevin Rosenberg ;;;; ;;;; Put in public domain by Kevin Rosenberg -;;;; $Id: tests.lisp,v 1.1 2003/08/04 06:00:01 kevin Exp $ +;;;; $Id: tests.lisp,v 1.2 2003/08/04 09:46:44 kevin Exp $ ;;;; ************************************************************************* (defpackage #:xltest-tests @@ -15,8 +15,76 @@ (in-package #:xltest-tests) -(defclass xltests (test-fixture) - () - ) +(defclass was-run (test-fixture) + ((log :accessor ws-log))) + + +(defmethod setup ((self was-run)) + (setf (ws-log self) "setup ")) + +(defmethod teardown ((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 "))) + +(defmethod test-broken-method ((self was-run)) + (assert-equal pi (/ 22 7))) + +(defmethod test-error-method ((self was-run)) + (error "Err")) + +(defclass test-case-test (test-fixture) + ((result :accessor result))) + +(defmethod setup ((self test-case-test)) + (setf (result self) (make-instance 'test-result))) + +(defmethod test-template-method ((self test-case-test)) + (let ((test (make-test 'was-run 'test-method))) + (run-test test (result self)) + (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))))) + +(defmethod test-thunk ((self test-case-test)) + (let ((test (make-test 'was-run '"Test Failure" + :test-thunk + (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))))) + +(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))))) + +(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))))) + +(defmethod test-suite ((self test-case-test)) + (let ((suite (make-test-suite "TestSuite"))) + (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)))) + +(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)))) + +(text-testrunner (make-test-suite 'test-case-test)) -(defmethod xltes diff --git a/xltest.asd b/xltest.asd index 7cbf663..e332f76 100644 --- a/xltest.asd +++ b/xltest.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Aug 2003 ;;;; -;;;; $Id: xltest.asd,v 1.1 2003/08/04 06:00:01 kevin Exp $ +;;;; $Id: xltest.asd,v 1.2 2003/08/04 09:46:44 kevin Exp $ ;;;; ************************************************************************* (defpackage #:xltest-system (:use #:asdf #:cl)) @@ -30,7 +30,7 @@ (oos 'test-op 'xltest-tests)) (defsystem xltest-tests - :depends-on (xltest-tests) + :depends-on (xltest) :components ((:file "tests"))) (defmethod perform ((o test-op) (c (eql (find-system 'xltest-tests))))