suite.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; ID:      $Id$
   6 ;;;; Purpose: Suite functions for XLUnit
   7 ;;;;
   8 ;;;; *************************************************************************
   9
  10 (in-package #:xlunit)
  11
  12 (defclass test-suite (test)
  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 add-test ((ob test-suite) (new-test test))
  23   (remove-test new-test ob)
  24   (setf (tests ob) (append (tests ob) (list new-test))))
  25
  26
  27 (defmethod run-on-test-results ((ob test-suite) (result test-results)
  28                                 &key (handle-errors t))
  29   (mapc #'(lambda (composite)  ;;test-case or suite
  30             (run-on-test-results composite result
  31                                 :handle-errors handle-errors))
  32         (tests ob)))
  33
  34 (defmethod named-test (name (suite test-suite))
  35   (some (lambda (test-or-suite)
  36           (when (and (typep test-or-suite 'test-case)
  37                      (equal name (name test-or-suite)))
  38             test-or-suite))
  39         (tests suite)))
  40
  41 (defmethod remove-test ((test test) (suite test-suite))
  42   (setf (tests suite)
  43     (delete-if #'(lambda (existing-tests-or-suite)
  44                    (cond ((typep existing-tests-or-suite 'test-suite)
  45                           (eq existing-tests-or-suite test))
  46                          ((typep existing-tests-or-suite 'test-case)
  47                           (eql (name existing-tests-or-suite)
  48                                (name test)))))
  49                (tests suite))))
  50
  51 ;; Dynamic test suite
  52
  53 (defun find-test-generic-functions (instance)
  54   "Return a list of symbols for generic functions specialized on the
  55 class of an instance and whose name begins with the string 'test-'.
  56 This is used to dynamically generate a list of tests for a fixture."
  57   (let ((res)
  58         (package (symbol-package (class-name (class-of instance)))))
  59     (do-symbols (s package)
  60       (when (and (> (length (symbol-name s)) 5)
  61                  (string-equal "test-" (subseq (symbol-name s) 0 5))
  62                  (fboundp s)
  63                  (typep (symbol-function s) 'generic-function)
  64                  (ignore-errors
  65                    (plusp (length (compute-applicable-methods
  66                                    (ensure-generic-function s)
  67                                    (list instance))))))
  68         (push s res)))
  69     (nreverse res)))
  70
  71
  72 (defmacro def-test-method (method-name ((instance-name class-name)
  73                                         &key (run t))
  74                            &body method-body)
  75   `(let ((,instance-name
  76           (make-instance ',class-name
  77             :name ',method-name)))
  78      (setf (method-body ,instance-name)
  79            #'(lambda() ,@method-body))
  80      (add-test (suite ,instance-name) ,instance-name)
  81      (when ,run
  82        (textui-test-run ,instance-name))))