suite.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; ID:      $Id: suite.lisp,v 1.2 2003/08/04 12:16:13 kevin Exp $
   6 ;;;; Purpose: Suite functions for XLUnit
   7 ;;;;
   8 ;;;; *************************************************************************
   9
  10 (in-package #:xlunit)
  11
  12 (defclass test-suite ()
  13   ((name :initarg :name :reader test-suite-name)
  14    (tests :initarg :tests :accessor tests-hash
  15           :initform (make-hash-table :test 'equal))
  16    (description :initarg :description :reader description
  17                 :initform "No description.")))
  18
  19
  20 (defmethod setup-testsuite-named (name)
  21   (declare (ignore name))
  22   t)
  23
  24 (defmethod teardown-testsuite-named (name)
  25   (declare (ignore name))
  26   t)
  27
  28 (defmethod run-test ((suite test-suite)
  29                      &key (result (make-instance 'test-result))
  30                      (handle-errors t))
  31   (setup-testsuite-named (slot-value suite 'name))
  32   (dolist (test (tests suite))
  33     (run-test test :result result :handle-errors handle-errors))
  34   (teardown-testsuite-named (slot-value suite 'name))
  35   result)
  36
  37 (defmethod tests ((suite test-suite))
  38   (let ((tlist nil))
  39     (maphash #'(lambda (k v)
  40                  (declare (ignore k))
  41                  (setf tlist (cons v tlist)))
  42              (tests-hash suite))
  43     (reverse tlist)))
  44
  45
  46 (defun make-test-suite (name-or-fixture &optional description testspecs)
  47   "Returns a new test-suite based on a name and TESTSPECS or a fixture
  48 instance"
  49   (etypecase name-or-fixture
  50     (symbol
  51      (make-test-suite-for-fixture (make-instance name-or-fixture)))
  52     (string
  53      (let ((suite (make-instance 'test-suite :name name-or-fixture
  54                                  :description description)))
  55        (dolist (testspec testspecs)
  56          (add-test (apply #'make-test testspec) suite))
  57        suite))))
  58
  59
  60 (defmethod add-test ((test test-fixture) (suite test-suite))
  61   (setf (gethash (test-name test) (tests-hash suite)) test))
  62
  63 (defmethod add-test ((test test-suite) (suite test-suite))
  64   (setf (gethash (test-suite-name test) (tests-hash suite)) test))
  65
  66 (defmethod remove-test ((test test-fixture) (suite test-suite))
  67   (remhash (test-name test) (tests-hash suite)))
  68
  69 (defmethod remove-test ((test test-suite) (suite test-suite))
  70   (remhash (test-suite-name test) (tests-hash suite)))
  71
  72 (defmethod test-named ((name string) (suite test-suite))
  73   (gethash name (tests-hash suite)))
  74
  75
  76 ;; Dynamic test suite
  77
  78 (defun make-test-suite-for-fixture
  79     (fixture &key
  80              (name
  81               (format nil "Automatic for ~A"
  82                       (if (slot-boundp fixture 'test-name)
  83                           (test-name fixture)
  84                         (type-of fixture))))
  85              description)
  86   (let ((suite  (make-instance 'test-suite
  87                   :name name
  88                   :description description))
  89         (fns (find-test-generic-functions fixture)))
  90     (dolist (fn fns)
  91       (make-test (class-name (class-of fixture)) fn
  92                  :test-suite suite))
  93     suite))
  94
  95 (defun find-test-generic-functions (instance)
  96   "Return a list of symbols for generic functions specialized on the
  97 class of an instance and whose name begins with the string 'test-'.
  98 This is used to dynamically generate a list of tests for a fixture."
  99   (let ((res)
 100         (package (symbol-package (class-name (class-of instance)))))
 101     (do-symbols (s package)
 102       (when (and (> (length (symbol-name s)) 5)
 103                  (string-equal "test-" (subseq (symbol-name s) 0 5))
 104                  (fboundp s)
 105                  (typep (symbol-function s) 'generic-function)
 106                  (plusp (length (compute-applicable-methods
 107                                  (ensure-generic-function s)
 108                                  (list instance)))))
 109         (push s res)))
 110     (nreverse res)))
 111
 112
 113 ;;; Test Runners
 114
 115 (defmethod text-testrunner ((suite test-suite) &key (stream t)
 116                                                     (handle-errors t))
 117   (let* ((start-time (get-internal-real-time))
 118          (result (run-test suite :handle-errors handle-errors))
 119          (seconds (/ (- (get-internal-real-time) start-time)
 120                      internal-time-units-per-second)))
 121     (result-printer result seconds stream)))
 122