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