--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: example.lisp
+;;;; 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 $
+;;;; *************************************************************************
+
+(defpackage #:xltest-example
+ (:use #:cl #:xltest)
+ (:export
+ #:math-test-suite))
+
+(in-package #:xltest-example)
+
+;;; First we define some basic fixtures that we are going to need to
+;;; perform our tests. A fixture is a place to hold data we need
+;;; 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))
+ (:documentation "Test fixture for math testing"))
+
+;;; Then we define a setup method for the fixture. This method is run
+;;; prior to perfoming any test with an instance of this fixture. It
+;;; should perform all initialization needed, and assume that it is starting
+;;; with a pristine environment, well to a point, use your head here.
+
+(defmethod setup ((fix math-fixture))
+ (setf (numbera fix) 2)
+ (setf (numberb fix) 3))
+
+;;; Then we define a teardown method, which should return the instance
+;;; to it's original form and reset the environment. In this case
+;;; there is little for us to do since the fixture is quite static.
+;;; In other cases we may need to clear some database tables, or
+;;; otherwise get rid of state built up while perofmring the test.
+;;; Here we just return T.
+
+(defmethod teardown ((fix math-fixture))
+ t)
+
+;;; Once we hav a fixture we can start defining method on it which
+;;; will perform tests. These methods should take one argument, an
+;;; instance of the fixture. The method performs some operation and
+;;; then performs some tests to determine if the proper behavior
+;;; occured. If there is a failure to behave as excpeted the method
+;;; raises a test-failure object by calling the method FAILURE. This
+;;; is much like calling ERROR in that it stops processing that
+;;; method. Each method should only check for one aspect of behavior.
+;;; This way triggering one failure would not result in another
+;;; behavior check from being skipped. It does not matter what these
+;;; methods return
+
+(defmethod test-addition ((test math-fixture))
+ (let ((result (+ (numbera test) (numberb test))))
+ (test-assert (= result 5))))
+
+(defmethod test-subtraction ((test math-fixture))
+ (let ((result (- (numberb test) (numbera test))))
+ (assert-equal result 1)))
+
+;;; This method is meant to signal a failure
+(defmethod test-subtraction-2 ((test math-fixture))
+ (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)
+
+(report-result (run-test *dynamic-math-test-suite*
+ :handle-errors t) :verbose nil)
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: src.lisp
+;;;; Purpose: eXtreme Lisp Test Suite
+;;;; 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 $
+;;;; *************************************************************************
+
+(in-package #:xltest)
+
+
+(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."))
+
+(defmethod setup ((test test-fixture))
+ "Method called before performing a test, should set up the
+environment the test-case needs to operate in."
+ t)
+
+(defmethod teardown ((test test-fixture))
+ "Method called after performing a test. Should reverse everything that the
+setup method did for this instance."
+ t)
+
+(define-condition test-failure (simple-condition) ()
+ (:documentation "Base class for all test failures."))
+
+(defun failure (format-str &rest args)
+ "Signal a test failure and exit the test."
+ (signal 'test-failure
+ :format-control format-str
+ :format-arguments args))
+
+(defmacro test-assert (test)
+ `(unless ,test
+ (failure "Test assertion failed: ~s" ',test)))
+
+(defun assert-equal (v1 v2)
+ (unless (equal v1 v2)
+ (failure "Test equals failed: ~s ~s" v1 v2)))
+
+(defun assert-true (v)
+ (unless v
+ (failure "Test true failed: ~s" v)))
+
+(defun assert-false (v)
+ (when v
+ (failure "Test false failed")))
+
+
+(defmethod perform-test ((test test-fixture))
+ "Default method for performing tests upon a 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 (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 ()))
+ (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))
+ "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
+ :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)
+ (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-case 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)))
+
+(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)))))
+
+
+;;; Dynamic test suite addition by Kevin Rosenberg 8/2003
+
+(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-case fn (class-name (class-of fixture))
+ :test-thunk 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)
+ (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))))
+ (nreverse res)))
+
+
+
projects / xlunit.git / commitdiff