src.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:        src.lisp
   6 ;;;; Purpose:     eXtreme Lisp Test Suite
   7 ;;;; Authors:     Kevin Rosenberg and Craig Brozefsky
   8 ;;;;
   9 ;;;; $Id: src.lisp,v 1.3 2003/08/04 09:50:33 kevin Exp $
  10 ;;;; *************************************************************************
  11
  12 (in-package #:xlunit)
  13
  14
  15 (defclass test-fixture ()
  16   ((test-thunk
  17     :initarg :test-thunk :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-condition (simple-condition)
  46   ()
  47   (:documentation "Base class for all test failures."))
  48
  49 (defclass test-failure ()
  50   ((failed-test :initarg :failed-test :reader failed-test)
  51    (thrown-condition :initarg :thrown-condition :reader thrown-condition)))
  52
  53 (defmethod print-object ((obj test-failure) stream)
  54   (print-unreadable-object (obj stream :type t :identity nil)
  55     (format stream "~A: " (failed-test obj))
  56     (apply #'format stream
  57            (simple-condition-format-control (thrown-condition obj))
  58            (simple-condition-format-arguments (thrown-condition obj)))))
  59
  60 (defmethod is-failure ((failure test-failure))
  61   (typep (thrown-condition failure) 'test-failure-condition))
  62
  63 (defun failure (format-str &rest args)
  64   "Signal a test failure and exit the test."
  65   (signal 'test-failure-condition
  66           :format-control format-str
  67           :format-arguments args))
  68
  69 (defmacro test-assert (test &optional msg)
  70   `(unless ,test
  71     (failure "Test assertion: ~s" ',test)))
  72
  73 (defun assert-equal (v1 v2 &optional msg)
  74   (unless (equal v1 v2)
  75     (failure "Test equal: ~s ~s" v1 v2)))
  76
  77 (defun assert-true (v &optional msg)
  78   (unless v
  79     (failure "Test true: ~s [~A]" v (if msg msg ""))))
  80
  81 (defun assert-false (v &optional msg)
  82   (when v
  83     (failure "Test false ~A" (if msg msg ""))))
  84
  85
  86 (defmethod perform-test ((test test-fixture))
  87   "Default method for performing tests upon a test-fixture."
  88   t)
  89
  90 (defmacro handler-case-if (test form &body cases)
  91   `(if ,test
  92        (handler-case
  93         ,form
  94         ,@cases)
  95      ,form))
  96
  97 (defmacro unwind-protect-if (test protected cleanup)
  98   `(if ,test
  99        (unwind-protect
 100            ,protected
 101          ,cleanup)
 102      (progn ,protected ,cleanup)))
 103
 104 (defclass test-result ()
 105   ((test :initarg :test :reader result-test)
 106    (count :initform 0 :accessor test-count)
 107    (failures :initarg :failures :reader test-failures :initform nil)
 108    (errors :initarg :errors :reader test-errors :initform nil))
 109   (:documentation "The result of applying a test"))
 110
 111 (defclass test-suite ()
 112   ((name :initarg :name :reader test-suite-name)
 113    (tests :initarg :tests :accessor tests-hash
 114           :initform (make-hash-table :test 'equal))
 115    (description :initarg :description :reader description
 116                 :initform "No description.")))
 117
 118 (defmethod setup-testsuite-named (name)
 119   (declare (ignore name))
 120   t)
 121
 122 (defmethod teardown-testsuite-named (name)
 123   (declare (ignore name))
 124   t)
 125
 126 (defmethod run-test ((suite test-suite) (result test-result)
 127                      &key (handle-errors t))
 128   (setup-testsuite-named (slot-value suite 'name))
 129   (dolist (test (tests suite))
 130     (run-test test result :handle-errors handle-errors))
 131   (teardown-testsuite-named (slot-value suite 'name))
 132   (values))
 133
 134 (defmethod run-test ((test test-fixture) result &key (handle-errors t))
 135   "Perform the test represented by the given test-case or test-suite.
 136 Returns one or more test-result objects, one for each test-case
 137 performed."
 138   (incf (test-count result))
 139   (with-slots (failures errors) result
 140     (unwind-protect-if handle-errors
 141         (handler-case-if handle-errors
 142          (let ((res (progn (setup test)
 143                            (funcall (test-thunk test) test))))
 144            (if (typep res 'test-failure-condition)
 145                (push (make-instance 'test-failure
 146                        :failed-test test
 147                        :thrown-condition res)
 148                      failures)))
 149          (test-failure-condition (failure)
 150                                  (push (make-instance 'test-failure
 151                                          :failed-test test
 152                                          :thrown-condition failure)
 153                                        failures))
 154          (error (err)
 155                 (push (make-instance 'test-failure
 156                         :failed-test test
 157                         :thrown-condition err)
 158                       errors)))
 159         (if handle-errors
 160             (handler-case
 161                 (teardown test)
 162               (error (err)
 163                 (push
 164                  (make-instance 'test-failure
 165                    :failed-test test :thrown-condition err)
 166                  errors)))
 167           (teardown test))))
 168   (values))
 169
 170
 171 (defun make-test (fixture name &key test-thunk test-suite description)
 172   "Create a test-case which is an instance of FIXTURE.  TEST-THUNK is
 173 the method that will be invoked when perfoming this test, and can be a
 174 symbol or a lambda taking a single argument, the test-fixture
 175 instance.  DESCRIPTION is obviously what it says it is."
 176   (let ((newtest (make-instance fixture
 177                    :test-name (string name)
 178                    :test-thunk
 179                    (if(and (symbolp name) (null test-thunk))
 180                        name
 181                      test-thunk)
 182                    :description description)))
 183        (if test-suite (add-test newtest test-suite))
 184        newtest))
 185
 186 (defmethod tests ((suite test-suite))
 187   (let ((tlist nil))
 188     (maphash #'(lambda (k v)
 189                  (declare (ignore k))
 190                  (setf tlist (cons v tlist)))
 191              (tests-hash suite))
 192     (reverse tlist)))
 193
 194 (defun make-test-suite (name-or-fixture &optional description testspecs)
 195   "Returns a new test-suite based on a name and TESTSPECS or a fixture
 196 instance"
 197   (etypecase name-or-fixture
 198     (symbol
 199      (make-test-suite-for-fixture (make-instance name-or-fixture)))
 200     (string
 201      (let ((suite (make-instance 'test-suite :name name-or-fixture
 202                                  :description description)))
 203        (dolist (testspec testspecs)
 204          (add-test (apply #'make-test testspec) suite))
 205        suite))))
 206
 207 (defmethod add-test ((test test-fixture) (suite test-suite))
 208   (setf (gethash (test-name test) (tests-hash suite)) test))
 209
 210 (defmethod add-test ((test test-suite) (suite test-suite))
 211   (setf (gethash (test-suite-name test) (tests-hash suite)) test))
 212
 213 (defmethod remove-test ((test test-fixture) (suite test-suite))
 214   (remhash (test-name test) (tests-hash suite)))
 215
 216 (defmethod remove-test ((test test-suite) (suite test-suite))
 217   (remhash (test-suite-name test) (tests-hash suite)))
 218
 219 (defmethod test-named ((name string) (suite test-suite))
 220   (gethash name (tests-hash suite)))
 221
 222 (defmethod was-successful ((result test-result))
 223   (and (null (test-failures result))
 224        (null (test-errors result))))
 225
 226 (defmethod text-testrunner ((suite test-suite) &key (stream t)
 227                                                     (handle-errors t))
 228   (let ((result (make-instance 'test-result))
 229         (start-time (get-internal-real-time)))
 230     (run-test suite result :handle-errors handle-errors)
 231     (let ((seconds (/ (- (get-internal-real-time) start-time)
 232                       internal-time-units-per-second)))
 233       (result-printer result seconds stream))))
 234
 235 (defun result-printer (result seconds stream)
 236   (format stream "~&Time: ~D~%~%" (coerce seconds 'float))
 237   (print-defects (test-errors result) "error" stream)
 238   (print-defects (test-failures result) "failure" stream)
 239   (if (was-successful result)
 240       (format stream "OK (~D tests)~%" (test-count result))
 241     (progn
 242       (format stream "~%FAILURES!!!~%")
 243       (format stream "Tests run: ~D, Failures: ~D, Errors: ~D~%"
 244               (test-count result) (length (test-failures result))
 245               (length (test-errors result))))))
 246
 247 (defun print-defects (defects type stream)
 248   (when defects
 249     (let ((count (length defects)))
 250       (if (= count 1)
 251           (format stream "~&There was ~D ~A:~%" count type)
 252         (format stream "~&There were ~D ~As:~%" count type))
 253       (dotimes (i count)
 254         (let ((defect (nth i defects)))
 255           (format stream "~&~D) ~A " i (class-name
 256                                         (class-of (failed-test defect))))
 257           (apply #'format stream (simple-condition-format-control
 258                                   (thrown-condition defect))
 259                  (simple-condition-format-arguments
 260                   (thrown-condition defect)))
 261           (fresh-line stream))))))
 262
 263 (defmethod summary ((result test-result))
 264   (format nil "~D run, ~D errored, ~D failed"
 265           (test-count result) (length (test-errors result))
 266           (length (test-failures result))))
 267
 268 ;;; Dynamic test suite addition by Kevin Rosenberg 8/2003
 269
 270 (defun make-test-suite-for-fixture
 271     (fixture &key
 272              (name
 273               (format nil "Automatic for ~A"
 274                       (if (slot-boundp fixture 'test-name)
 275                           (test-name fixture)
 276                         (type-of fixture))))
 277              description)
 278   (let ((suite  (make-instance 'test-suite
 279                   :name name
 280                   :description description))
 281         (fns (find-test-generic-functions fixture)))
 282     (dolist (fn fns)
 283       (make-test (class-name (class-of fixture)) fn
 284                  :test-suite suite))
 285     suite))
 286
 287 (defun find-test-generic-functions (instance)
 288   "Return a list of symbols for generic functions specialized on the
 289 class of an instance and whose name begins with the string 'test-'.
 290 This is used to dynamically generate a list of tests for a fixture."
 291   (let ((res)
 292         (package (symbol-package (class-name (class-of instance)))))
 293     (do-symbols (s package)
 294       (when (and (> (length (symbol-name s)) 5)
 295                  (string-equal "test-" (subseq (symbol-name s) 0 5))
 296                  (fboundp s)
 297                  (typep (symbol-function s) 'generic-function)
 298                  (plusp (length (compute-applicable-methods
 299                                  (ensure-generic-function s)
 300                                  (list instance)))))
 301         (push s res)))
 302     (nreverse res)))
 303
 304
 305