+;;;; -*- 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)))
+
+
+