suite.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; ID:      $Id: suite.lisp,v 1.4 2003/08/04 16:42:27 kevin Exp $
   6 ;;;; Purpose: Suite functions for XLUnit
   7 ;;;;
   8 ;;;; *************************************************************************
   9
  10 (in-package #:xlunit)
  11
  12 (defclass test-suite ()
  13   ((name :initform "" :initarg :name :reader test-suite-name)
  14    (tests :initarg :tests :accessor tests :initform nil)
  15    (description :initarg :description :reader description
  16                 :initform "No description.")))
  17
  18 (defmacro get-suite (class-name)
  19   `(suite (make-instance ',class-name)))
  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-on-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-on-test test :result result :handle-errors handle-errors))
  36   (teardown-testsuite-named (slot-value suite 'name))
  37   result)
  38
  39
  40 (defmethod add-test ((ob test-suite) (new-test test))
  41   (setf (tests ob)
  42         (delete-if #'(lambda (existing-tests-or-suite)
  43                        (cond ((typep existing-tests-or-suite 'test-suite)
  44                               (eq existing-tests-or-suite new-test))
  45                              ((typep existing-tests-or-suite 'test-case)
  46                               (eql (name existing-tests-or-suite)
  47                                    (name new-test)))))
  48                    (tests ob)))
  49   (setf (tests ob) (append (tests ob) (list new-test))))
  50
  51 #|
  52 (defmethod remove-test ((test test-case) (suite test-suite))
  53   (remhash (name test) (tests-hash suite)))
  54
  55 (defmethod remove-test ((test test-suite) (suite test-suite))
  56   (remhash (test-suite-name test) (tests-hash suite)))
  57
  58 (defmethod named ((name string) (suite test-suite))
  59   (gethash name (tests-hash suite)))
  60 |#
  61
  62 ;; Dynamic test suite
  63
  64 (defun make-test-suite-for-fixture
  65     (fixture &key
  66              (name
  67               (format nil "Automatic for ~A"
  68                       (if (slot-boundp fixture 'name)
  69                           (name fixture)
  70                         (type-of fixture))))
  71              description)
  72   (let ((suite  (make-instance 'test-suite
  73                   :name name
  74                   :description description))
  75         (fns (find-test-generic-functions fixture)))
  76     (dolist (fn fns)
  77       (make-test (class-name (class-of fixture)) fn
  78                  :test-suite suite))
  79     suite))
  80
  81 (defun find-test-generic-functions (instance)
  82   "Return a list of symbols for generic functions specialized on the
  83 class of an instance and whose name begins with the string 'test-'.
  84 This is used to dynamically generate a list of tests for a fixture."
  85   (let ((res)
  86         (package (symbol-package (class-name (class-of instance)))))
  87     (do-symbols (s package)
  88       (when (and (> (length (symbol-name s)) 5)
  89                  (string-equal "test-" (subseq (symbol-name s) 0 5))
  90                  (fboundp s)
  91                  (typep (symbol-function s) 'generic-function)
  92                  (ignore-errors
  93                    (plusp (length (compute-applicable-methods
  94                                    (ensure-generic-function s)
  95                                    (list instance))))))
  96         (push s res)))
  97     (nreverse res)))
  98
  99
 100 ;----------------------------------------------------------------------
 101 ; macro def-test-method
 102 ;
 103 ; Creates the representation of a test method (included within a
 104 ; test-case object) and add it to the corresponding suite class.
 105 ; => clos version of the pluggable selector pattern
 106 ;
 107 ; use:  (def-test-method test-assert-false (clos-unit-test)
 108 ;          (assert-true (eql (+ 1 2) 4) "comment"))
 109 ;
 110 ; new: it calls the textui-test-run function during eval, so to
 111 ;      allow the usual lisp-like incremental developing and test.
 112 ;----------------------------------------------------------------------
 113
 114 (defmacro def-test-method (method-name class-name &body method-body)
 115   `(let ((,(caar class-name)
 116           (make-instance ',(cadar class-name)
 117             :name ',method-name)))
 118      (setf (method-body ,(caar class-name))
 119            #'(lambda() ,@method-body))
 120      (add-test (suite ,(caar class-name)) ,(caar class-name))
 121      (textui-test-run ,(caar class-name))))
 122