suite.lisp

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