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 ;;;; Put in public domain by Kevin Rosenberg and onShore, Inc
  10 ;;;; $Id: src.lisp,v 1.1 2003/08/04 06:00:01 kevin Exp $
  11 ;;;; *************************************************************************
  12
  13 (in-package #:xltest)
  14
  15
  16 (defclass test-fixture ()
  17   ((test-thunk
  18     :initarg :test-thunk :reader test-thunk
  19     :initform 'perform-test
  20     :documentation
  21     "A thunk or symbol which will be applied to this instance, a
  22 test-case, to perform that test-case. Defaults to 'perform-test")
  23    (test-name
  24     :initarg :test-name
  25     :reader test-name
  26     :documentation
  27     "The name of this test-case, used in reports.")
  28    (test-description
  29     :initarg :description
  30     :reader description
  31     :documentation
  32     "Short description of this test-case, uses in reports"))
  33   (:documentation
  34    "Base class for test-fixtures.  Test-cases are instances of test-fixtures."))
  35
  36 (defmethod setup ((test test-fixture))
  37   "Method called before performing a test, should set up the
  38 environment the test-case needs to operate in."
  39   t)
  40
  41 (defmethod teardown ((test test-fixture))
  42   "Method called after performing a test.  Should reverse everything that the
  43 setup method did for this instance."
  44   t)
  45
  46 (define-condition test-failure (simple-condition) ()
  47   (:documentation "Base class for all test failures."))
  48
  49 (defun failure (format-str &rest args)
  50   "Signal a test failure and exit the test."
  51   (signal 'test-failure
  52           :format-control format-str
  53           :format-arguments args))
  54
  55 (defmacro test-assert (test)
  56   `(unless ,test
  57     (failure "Test assertion failed: ~s" ',test)))
  58
  59 (defun assert-equal (v1 v2)
  60   (unless (equal v1 v2)
  61     (failure "Test equals failed: ~s ~s" v1 v2)))
  62
  63 (defun assert-true (v)
  64   (unless v
  65     (failure "Test true failed: ~s" v)))
  66
  67 (defun assert-false (v)
  68   (when v
  69     (failure "Test false failed")))
  70
  71
  72 (defmethod perform-test ((test test-fixture))
  73   "Default method for performing tests upon a test-fixture."
  74   t)
  75
  76 (defmacro handler-case-if (test form &body cases)
  77   `(if ,test
  78        (handler-case
  79         ,form
  80         ,@cases)
  81      ,form))
  82
  83 (defmacro unwind-protect-if (test protected cleanup)
  84   `(if ,test
  85        (unwind-protect
  86            ,protected
  87          ,cleanup)
  88      (progn ,protected ,cleanup)))
  89
  90 (defmethod run-test ((test test-fixture) &key (handle-errors t))
  91   "Perform the test represented by the given test-case or test-suite.
  92 Returns one or more test-result objects, one for each test-case
  93 performed."
  94   (let ((failures ())
  95         (errs ()))
  96     (unwind-protect-if handle-errors
  97         (handler-case-if handle-errors
  98          (let ((res (progn (setup test)
  99                            (funcall (test-thunk test) test))))
 100            (if (typep res 'test-failure)
 101                (setf failures (cons res failures))))
 102          (test-failure (failure)
 103                        (setf failures (cons failure failures)))
 104          (t (err)
 105                 (setf errs (cons err errs))))
 106       (handler-case-if handle-errors
 107        (teardown test)
 108        (t (err)
 109           (setf errs (cons err errs)))))
 110     (make-instance 'test-result
 111                    :test test
 112                    :failures failures
 113                    :errors errs)))
 114
 115 (defmacro def-test-fixture (name supers slotdefs &rest class-options)
 116   "Define a new test-fixture class.  Works just like defclass, but
 117 ensure that test-fixture is a super."
 118   `(defclass ,name ,(append supers (list 'test-fixture))
 119      ,slotdefs ,@class-options))
 120
 121 (defun make-test-case (name fixture &key
 122                                     (test-thunk 'perform-test)
 123                                     (test-suite nil)
 124                                     (description nil))
 125   "Create a test-case which is an instance of FIXTURE.  TEST-THUNK is
 126 the method that will be invoked when perfoming this test, and can be a
 127 symbol or a lambda taking a single argument, the test-fixture
 128 instance.  DESCRIPTION is obviously what it says it is."
 129   (let ((newtest (make-instance fixture
 130                    :test-name name
 131                    :test-thunk test-thunk
 132                    :description description)))
 133        (if test-suite (add-test newtest test-suite))
 134        newtest))
 135
 136 (defclass test-suite ()
 137   ((name :initarg :name :reader test-suite-name)
 138    (tests :initarg :tests :accessor tests-hash
 139           :initform (make-hash-table :test 'equal))
 140    (description :initarg :description :reader description
 141                 :initform "No description.")))
 142
 143 (defmethod tests ((suite test-suite))
 144   (let ((tlist nil))
 145     (maphash #'(lambda (k v)
 146                  (declare (ignore k))
 147                  (setf tlist (cons v tlist)))
 148              (tests-hash suite))
 149     (reverse tlist)))
 150
 151 (defun make-test-suite (name-or-fixture &optional description testspecs)
 152   "Returns a new test-suite based on a name and TESTSPECS or a fixture
 153 instance"
 154   (etypecase name-or-fixture
 155     (symbol
 156      (make-test-suite-for-fixture (make-instance name-or-fixture)))
 157     (string
 158      (let ((suite (make-instance 'test-suite :name name-or-fixture
 159                                  :description description)))
 160        (dolist (testspec testspecs)
 161          (add-test (apply #'make-test-case testspec) suite))
 162        suite))))
 163
 164 (defmethod add-test ((test test-fixture) (suite test-suite))
 165   (setf (gethash (test-name test) (tests-hash suite)) test))
 166
 167 (defmethod add-test ((test test-suite) (suite test-suite))
 168   (setf (gethash (test-suite-name test) (tests-hash suite)) test))
 169
 170 (defmethod remove-test ((test test-fixture) (suite test-suite))
 171   (remhash (test-name test) (tests-hash suite)))
 172
 173 (defmethod remove-test ((test test-suite) (suite test-suite))
 174   (remhash (test-suite-name test) (tests-hash suite)))
 175
 176 (defmethod test-named ((name string) (suite test-suite))
 177   (gethash name (tests-hash suite)))
 178
 179 (defmethod setup-testsuite-named (name)
 180   (declare (ignore name))
 181   t)
 182
 183 (defmethod teardown-testsuite-named (name)
 184   (declare (ignore name))
 185   t)
 186
 187 (defmethod run-test ((suite test-suite) &key (handle-errors t))
 188   (let ((start-time (get-internal-real-time)))
 189     (setup-testsuite-named (slot-value suite 'name))
 190     (let ((res (mapcar (lambda (test) (run-test test
 191                                                 :handle-errors handle-errors))
 192                        (tests suite))))
 193       (teardown-testsuite-named (slot-value suite 'name))
 194       (make-instance 'suite-results
 195         :suite suite
 196         :test-results res
 197         :start-time start-time
 198         :stop-time (get-internal-real-time)))))
 199
 200
 201 (defclass test-result ()
 202   ((test :initarg :test :reader result-test)
 203    (failures :initarg :failures :reader test-failures :initform nil)
 204    (errors :initarg :errors :reader test-errors :initform nil))
 205   (:documentation "The result of applying a test"))
 206
 207 (defclass suite-results ()
 208   ((suite :initarg :suite :reader suite)
 209    (start-time :initarg :start-time :reader start-time)
 210    (stop-time :initarg :stop-time :reader stop-time)
 211    (test-results :initarg :test-results :reader test-results))
 212   (:documentation "Results of running a suite"))
 213
 214
 215 (defmethod report-result ((result test-result) &key (stream t)
 216                                                     (verbose nil))
 217   "Print out a test-result object for a report to STREAM, default to
 218 standard-output.  If VERBOSE is non-nil then will produce a lengthy
 219 and informative report, otherwise just prints wether the test passed
 220 or failed or errored out."
 221   (when (or verbose (test-failures result) (test-errors result))
 222     (when verbose
 223       (format stream
 224               "------------------------------------------------------~%"))
 225     (format stream "~A~A"
 226             (test-name (result-test result))
 227             (cond
 228              ((test-failures result) ":")
 229              ((test-errors result) ":")
 230              (t ": Passed")))
 231     (when (test-failures result)
 232       (format stream " Failures: ~{~A~^; ~}" (test-failures result)))
 233     (when (test-errors result)
 234       (format stream " Errors: ~{~A~^; ~}" (test-errors result)))
 235     (fresh-line stream)
 236     (when verbose
 237       (when (description (result-test result))
 238         (format stream "Description: ~A~%"
 239                 (description (result-test result)))))))
 240
 241 (defmethod report-result ((results suite-results) &key (stream t)
 242                                                        (verbose nil))
 243   (format stream "~&.............~%")
 244   (format stream "~&Time: ~D~%"
 245           (float
 246            (/ (- (stop-time results) (start-time results))
 247               internal-time-units-per-second)))
 248   (if (some (lambda (res) (or (test-failures res) (test-errors res)))
 249             (test-results results))
 250       (dolist (foo (test-results results))
 251         (report-result foo :stream stream :verbose verbose))
 252     (format stream "~&OK (~D tests)~%" (length (test-results results)))))
 253
 254
 255 ;;; Dynamic test suite addition by Kevin Rosenberg 8/2003
 256
 257 (defun make-test-suite-for-fixture
 258     (fixture &key
 259              (name
 260               (format nil "Automatic for ~A"
 261                       (if (slot-boundp fixture 'test-name)
 262                           (test-name fixture)
 263                         (type-of fixture))))
 264              description)
 265   (let ((suite  (make-instance 'test-suite
 266                   :name name
 267                   :description description))
 268         (fns (find-test-generic-functions fixture)))
 269     (dolist (fn fns)
 270       (make-test-case fn (class-name (class-of fixture))
 271                       :test-thunk fn
 272                       :test-suite suite))
 273     suite))
 274
 275 (defun find-test-generic-functions (instance)
 276   "Return a list of symbols for generic functions specialized on the
 277 class of an instance and whose name begins with the string 'test-'.
 278 This is used to dynamically generate a list of tests for a fixture."
 279   (let ((res)
 280         (package (symbol-package (class-name (class-of instance)))))
 281     (do-symbols (s package)
 282       (multiple-value-bind (sym status)
 283           (find-symbol (symbol-name s) package)
 284         (when (and (or (eq status :external)
 285                        (eq status :internal))
 286                    (fboundp sym)
 287                    (eq (symbol-package sym) package)
 288                    (> (length (symbol-name sym)) 5)
 289                    (string-equal "test-" (subseq (symbol-name sym) 0 5))
 290                    (typep (symbol-function sym) 'generic-function)
 291                    (plusp
 292                     (length
 293                      (compute-applicable-methods
 294                       (ensure-generic-function sym)
 295                       (list instance)))))
 296           (push sym res))))
 297     (nreverse res)))
 298
 299
 300