+++ /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
-;;;;
-;;;; $Id: src.lisp,v 1.3 2003/08/04 09:50:33 kevin Exp $
-;;;; *************************************************************************
-
-(in-package #:xlunit)
-
-
-(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-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-condition
- :format-control format-str
- :format-arguments args))
-
-(defmacro test-assert (test &optional msg)
- `(unless ,test
- (failure "Test assertion: ~s" ',test)))
-
-(defun assert-equal (v1 v2 &optional msg)
- (unless (equal v1 v2)
- (failure "Test equal: ~s ~s" v1 v2)))
-
-(defun assert-true (v &optional msg)
- (unless v
- (failure "Test true: ~s [~A]" v (if msg msg ""))))
-
-(defun assert-false (v &optional msg)
- (when v
- (failure "Test false ~A" (if msg msg ""))))
-
-
-(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)))
-
-(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."
- (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-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 (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))
-
-(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 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 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
-
-(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 (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-'.
-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)
- (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)))
-
-
-
projects / xlunit.git / blobdiff