--- /dev/null
+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.
--- /dev/null
+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).
+
+
--- /dev/null
+cl-xlunut (0.1.0-1) unstable; urgency=low
+
+ * Initial upload
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Mon, 4 Aug 2003 03:40:37 -0600
--- /dev/null
+Source: cl-xlunit
+Section: devel
+Priority: optional
+Maintainer: Kevin M. Rosenberg <kmr@debian.org>
+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.
--- /dev/null
+Debian Copyright Section
+========================
+
+Upstream Source URL: http://files.b9.com/xlunit/
+Upstream Authors: Kevin M. Rosenberg <kevin@rosenberg.net>
+Debian Maintainer: Kevin M. Rosenberg <kmr@debian.org>
+
+
+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.
--- /dev/null
+#! /bin/sh
+set -e
+
+LISP_PKG=xlunit
+
+# summary of how this script can be called:
+# * <postinst> `configure' <most-recently-configured-version>
+# * <old-postinst> `abort-upgrade' <new version>
+# * <conflictor's-postinst> `abort-remove' `in-favour' <package>
+# <new-version>
+# * <deconfigured's-postinst> `abort-deconfigure' `in-favour'
+# <failed-install-package> <version> `removing'
+# <conflicting-package> <version>
+# 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
+
+
--- /dev/null
+#! /bin/sh
+set -e
+
+LISP_PKG=xlunit
+
+# summary of how this script can be called:
+# * <prerm> `remove'
+# * <old-prerm> `upgrade' <new-version>
+# * <new-prerm> `failed-upgrade' <old-version>
+# * <conflictor's-prerm> `remove' `in-favour' <package> <new-version>
+# * <deconfigured's-prerm> `deconfigure' `in-favour'
+# <package-being-installed> <version> `removing'
+# <conflicting-package> <version>
+# 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
+
+
--- /dev/null
+#!/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
+
--- /dev/null
+#!/bin/bash -e
+
+dup xlunit -Uftp.med-info.com -D/home/ftp/xlunit -C"/home/kevin/bin/remove-old-versions xlunit latest" -su $*
;;;; 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)
;;; 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
(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)
;;;; 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)
#:test-failure
#:failure
#:run-test
- #:def-test-fixture
- #:make-test-case
+ #:make-test
#:make-test-suite
#:setup-testsuite-named
#:teardown-testsuite-named
#:assert-true
#:assert-false
#:test-assert
+ #:test-fixture
+ #:text-testrunner
+ #:summary
)
(:documentation "This is the XP TestSuite Framework."))
;;;; 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)
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))
,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)
(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))
(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
: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)
(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)))
;;;; 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
(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
;;;; 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))
(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))))
projects / xlunit.git / commitdiff