1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Suite functions for XLUnit
8 ;;;; *************************************************************************
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.")))
18 (defmacro get-suite (class-name)
19 `(suite (make-instance ',class-name)))
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))))
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))
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)))
41 (defmethod remove-test ((test test) (suite test-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)
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."
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))
63 (typep (symbol-function s) 'generic-function)
65 (plusp (length (compute-applicable-methods
66 (ensure-generic-function s)
72 (defmacro def-test-method (method-name ((instance-name class-name)
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)
82 (textui-test-run ,instance-name))))