xptestsuite.lisp

   1 ;;; -*- Mode: Lisp -*-
   2 ;;;; xptestsuite.lisp --- Test suite based on Extreme Programming
   3 ;;;;                      Framework by Kent Beck
   4 ;;;;
   5 ;;;; Inspired by http://www.xprogramming.com/testfram.htm
   6 ;;;;
   7 ;;;; Author: Craig Brozefsky <craig@onshore.com>
   8 ;;;; Put in public domain by onShore, Inc
   9 ;;;;
  10 ;;;; $Id: xptestsuite.lisp,v 1.2 2003/02/23 05:51:55 kevin Exp $
  11
  12 (in-package :xp-test)
  13
  14 (defclass test-fixture ()
  15   ((test-thunk
  16     :initarg :test-thunk
  17     :reader test-thunk
  18     :initform 'perform-test
  19     :documentation
  20     "A thunk or symbol which will be applied to this instance, a
  21 test-case, to perform that test-case. Defaults to 'perform-test")
  22    (test-name
  23     :initarg :test-name
  24     :reader test-name
  25     :documentation
  26     "The name of this test-case, used in reports.")
  27    (test-description
  28     :initarg :description
  29     :reader description
  30     :documentation
  31     "Short description of this test-case, uses in reports"))
  32   (:documentation
  33    "Base class for test-fixtures.  Test-cases are instances of test-fixtures."))
  34
  35 (defmethod setup ((test test-fixture))
  36   "Method called before performing a test, should set up the
  37 environment the test-case needs to operate in."
  38   t)
  39
  40 (defmethod teardown ((test test-fixture))
  41   "Method called after performing a test.  Should reverse everything that the
  42 setup method did for this instance."
  43   t)
  44
  45 (define-condition test-failure (simple-condition) ()
  46   (:documentation "Base class for all test failures."))
  47
  48 (defun failure (format-str &rest args)
  49   "Signal a test failure and exit the test."
  50   (signal 'test-failure
  51           #+(or cmu allegro openmcl) :format-control
  52           #-(or cmu allegro openmcl) :format-string
  53           format-str
  54           :format-arguments args))
  55
  56 (defmacro test-assert (test)
  57   `(unless ,test
  58     (failure "Test assertion failed: ~s" ',test)))
  59
  60
  61 (defmethod perform-test ((test test-fixture))
  62   "Default method for performing tests upon a test-fixture."
  63   t)
  64
  65 (defmacro handler-case-if (test form &body cases)
  66   `(if ,test
  67        (handler-case
  68         ,form
  69         ,@cases)
  70      ,form))
  71
  72 (defmacro unwind-protect-if (test protected cleanup)
  73   `(if ,test
  74        (unwind-protect
  75            ,protected
  76          ,cleanup)
  77      (progn ,protected ,cleanup)))
  78
  79 (defmethod run-test ((test test-fixture) &key (handle-errors t))
  80   "Perform the test represented by the given test-case or test-suite.
  81 Returns one or more test-result objects, one for each test-case
  82 performed."
  83   (let ((start-time (get-universal-time))
  84         (failures ())
  85         (errs ()))
  86     (unwind-protect-if handle-errors
  87         (handler-case-if handle-errors
  88          (let ((res (progn (setup test)
  89                            (apply (test-thunk test) (list test)))))
  90            (if (typep res 'test-failure)
  91                (setf failures (cons res failures))))
  92          (test-failure (failure)
  93                        (setf failures (cons failure failures)))
  94          (t (err)
  95             (setf errs (cons err errs))))
  96       (handler-case-if handle-errors
  97        (teardown test)
  98        (t (err)
  99           (setf errs (cons err errs)))))
 100     (make-instance 'test-result
 101                    :test test
 102                    :start-time start-time
 103                    :stop-time (get-universal-time)
 104                    :failures failures
 105                    :errors errs)))
 106
 107 (defmacro def-test-fixture (name supers slotdefs &rest class-options)
 108   "Define a new test-fixture class.  Works just like defclass, but
 109 ensure that test-fixture is a super."
 110   `(defclass ,name ,(append supers (list 'test-fixture))
 111      ,slotdefs ,@class-options))
 112
 113 (defmacro make-test-case (name fixture &key
 114                                (test-thunk 'perform-test)
 115                                (test-suite nil)
 116                                (description "No description."))
 117   "Create a test-case which is an instance of FIXTURE.  TEST-THUNK is
 118 the method that will be invoked when perfoming this test, and can be a
 119 symbol or a lambda taking a single argument, the test-fixture
 120 instance.  DESCRIPTION is obviously what it says it is."
 121   (let ((newtest (gensym "new-test")))
 122     `(let ((,newtest (make-instance ,fixture
 123                                     :test-name ,name
 124                                     :test-thunk ,(if (eq test-thunk 'perform-test)
 125                                                      ''perform-test
 126                                                    test-thunk)
 127                                     :description ,description)))
 128        (if ,test-suite (add-test ,newtest ,test-suite))
 129        ,newtest)))
 130
 131 (defclass test-suite ()
 132   ((name
 133     :initarg :name
 134     :reader test-suite-name)
 135    (tests
 136     :initarg :tests
 137     :accessor tests-hash
 138     :initform (make-hash-table :test 'equal))
 139    (description
 140     :initarg :description
 141     :reader description
 142     :initform "No description.")))
 143
 144 (defmethod tests ((suite test-suite))
 145   (let ((tlist nil))
 146     (maphash #'(lambda (k v)
 147                  (declare (ignore k))
 148                  (setf tlist (cons v tlist)))
 149              (tests-hash suite))
 150     (reverse tlist)))
 151
 152 (defmacro make-test-suite (name description &rest testspecs)
 153   "Returns a new test-suite.  TESTSPECS are just like lists of
 154 arguments to MAKE-TEST-CASE."
 155   (let* ((newsuite (gensym "test-suite"))
 156          (testforms (mapcar #'(lambda (spec)
 157                                 (list
 158                                  'add-test
 159                                  (cons 'make-test-case spec)
 160                                  newsuite))
 161                             testspecs)))
 162     `(let ((,newsuite (make-instance 'test-suite :name ,name
 163                                      :description ,description)))
 164        ,@testforms
 165        ,newsuite)))
 166
 167 (defmethod add-test ((test test-fixture) (suite test-suite))
 168   (setf (gethash (test-name test) (tests-hash suite)) test))
 169
 170 (defmethod add-test ((test test-suite) (suite test-suite))
 171   (setf (gethash (test-suite-name test) (tests-hash suite)) test))
 172
 173 (defmethod remove-test ((test test-fixture) (suite test-suite))
 174   (remhash (test-name test) (tests-hash suite)))
 175
 176 (defmethod remove-test ((test test-suite) (suite test-suite))
 177   (remhash (test-suite-name test) (tests-hash suite)))
 178
 179 (defmethod test-named ((name string) (suite test-suite))
 180   (gethash name (tests-hash suite)))
 181
 182 (defmethod setup-testsuite-named (name)
 183   (declare (ignore name))
 184   t)
 185
 186 (defmethod teardown-testsuite-named (name)
 187   (declare (ignore name))
 188   t)
 189
 190 (defmethod run-test ((suite test-suite) &key (handle-errors t))
 191   (setup-testsuite-named (slot-value suite 'name))
 192   (let ((res (mapcar (lambda (test) (run-test test
 193                                               :handle-errors handle-errors))
 194                      (tests suite))))
 195     (teardown-testsuite-named (slot-value suite 'name))
 196     res))
 197
 198
 199 (defclass test-result ()
 200   ((start-time
 201     :initarg :start-time
 202     :reader start-time)
 203    (stop-time
 204     :initarg :stop-time
 205     :reader stop-time)
 206    (test
 207     :initarg :test
 208     :reader result-test)
 209    (failures
 210     :initarg :failures
 211     :reader test-failures
 212     :initform nil)
 213    (errors
 214     :initarg :errors
 215     :reader test-errors
 216     :initform nil))
 217   (:documentation
 218    "The result of applying a test"))
 219
 220 (defmethod report-result ((result test-result) &key (stream t) (verbose nil))
 221   "Print out a test-result object for a report to STREAM, default to
 222 standard-output.  If VERBOSE is non-nil then will produce a lengthy
 223 and informative report, otherwise just prints wether the test passed
 224 or failed or errored out."
 225   (if verbose (format stream
 226                       "------------------------------------------------------~%"))
 227   (format stream "Test ~A ~A ~%"
 228           (test-name (result-test result))
 229           (cond
 230            ((test-failures result) "Failed")
 231            ((test-errors result) "Errored")
 232            (t "Passed")))
 233   (if verbose
 234       (progn
 235         (format stream "Description: ~A~%" (description (result-test result)))
 236         (if (test-failures result)
 237             (progn
 238               (format stream "Failures:~%")
 239               (mapcar #'(lambda (fail) (format stream "    ~A" fail))
 240                       (test-failures result))))
 241         (if (test-errors result)
 242             (progn
 243               (format stream "Errors:~%")
 244               (mapcar #'(lambda (fail) (format stream "    ~A" fail))
 245                       (test-errors result))))))
 246   (format stream "~%~%"))
 247
 248 (defmethod report-result ((results list) &key (stream t) (verbose nil))
 249   (dolist (foo results)
 250     (report-result foo :stream stream :verbose verbose)))
 251
 252
 253
 254
 255
 256
 257