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