;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; ID: $Id: suite.lisp,v 1.3 2003/08/04 16:13:58 kevin Exp $
+;;;; ID: $Id: suite.lisp,v 1.6 2003/08/04 19:31:34 kevin Exp $
;;;; Purpose: Suite functions for XLUnit
;;;;
;;;; *************************************************************************
(in-package #:xlunit)
-(defclass test-suite ()
+(defclass test-suite (test)
((name :initform "" :initarg :name :reader test-suite-name)
(tests :initarg :tests :accessor tests :initform nil)
(description :initarg :description :reader description
`(suite (make-instance ',class-name)))
-(defmethod setup-testsuite-named (name)
- (declare (ignore name))
- t)
-
-(defmethod teardown-testsuite-named (name)
- (declare (ignore name))
- t)
-
-(defmethod run-on-test ((suite test-suite)
- &key (result (make-instance 'test-result))
- (handle-errors t))
- (setup-testsuite-named (slot-value suite 'name))
- (dolist (test (tests suite))
- (run-on-test test :result result :handle-errors handle-errors))
- (teardown-testsuite-named (slot-value suite 'name))
- result)
-
-
(defmethod add-test ((ob test-suite) (new-test test))
- (setf (tests ob)
- (delete-if #'(lambda (existing-tests-or-suite)
- (cond ((typep existing-tests-or-suite 'test-suite)
- (eq existing-tests-or-suite new-test))
- ((typep existing-tests-or-suite 'test-case)
- (eql (name existing-tests-or-suite)
- (name new-test)))))
- (tests ob)))
+ (remove-test new-test ob)
(setf (tests ob) (append (tests ob) (list new-test))))
-#|
-(defmethod remove-test ((test test-case) (suite test-suite))
- (remhash (name test) (tests-hash suite)))
-
-(defmethod remove-test ((test test-suite) (suite test-suite))
- (remhash (test-suite-name test) (tests-hash suite)))
-(defmethod named ((name string) (suite test-suite))
- (gethash name (tests-hash suite)))
-|#
+(defmethod run-on-test-results ((ob test-suite) (result test-results)
+ &key (handle-errors t))
+ (mapc #'(lambda (composite) ;;test-case or suite
+ (run-on-test-results composite result
+ :handle-errors handle-errors))
+ (tests ob)))
+
+(defmethod named-test (name (suite test-suite))
+ (some (lambda (test-or-suite)
+ (when (and (typep test-or-suite 'test-case)
+ (equal name (name test-or-suite)))
+ test-or-suite))
+ (tests suite)))
+
+(defmethod remove-test ((test test) (suite test-suite))
+ (setf (tests suite)
+ (delete-if #'(lambda (existing-tests-or-suite)
+ (cond ((typep existing-tests-or-suite 'test-suite)
+ (eq existing-tests-or-suite new-test))
+ ((typep existing-tests-or-suite 'test-case)
+ (eql (name existing-tests-or-suite)
+ (name test)))))
+ (tests suite))))
;; Dynamic test suite
-(defun make-test-suite-for-fixture
- (fixture &key
- (name
- (format nil "Automatic for ~A"
- (if (slot-boundp fixture 'name)
- (name fixture)
- (type-of fixture))))
- description)
- (let ((suite (make-instance 'test-suite
- :name name
- :description description))
- (fns (find-test-generic-functions fixture)))
- (dolist (fn fns)
- (make-test (class-name (class-of fixture)) fn
- :test-suite suite))
- suite))
-
(defun find-test-generic-functions (instance)
"Return a list of symbols for generic functions specialized on the
class of an instance and whose name begins with the string 'test-'.
; allow the usual lisp-like incremental developing and test.
;----------------------------------------------------------------------
-(defmacro def-test-method (method-name class-name &body method-body)
- `(let ((,(caar class-name)
- (make-instance ',(cadar class-name)
+(defmacro def-test-method ((method-name instance-name class-name
+ &key (run t))
+ &body method-body)
+ `(let ((,instance-name
+ (make-instance ',class-name
:name ',method-name)))
- (setf (method-body ,(caar class-name))
+ (setf (method-body ,instance-name)
#'(lambda() ,@method-body))
- (add-test (suite ,(caar class-name)) ,(caar class-name))
- (textui-test-run ,(caar class-name))))
+ (add-test (suite ,instance-name) ,instance-name)
+ (when ,run
+ (textui-test-run ,instance-name))))
-
-;;; Test Runners
-
-(defmethod textui-test-run ((suite test-suite) &key (stream t)
- (handle-errors t))
- (let* ((start-time (get-internal-real-time))
- (result (run-on-test suite :handle-errors handle-errors))
- (seconds (/ (- (get-internal-real-time) start-time)
- internal-time-units-per-second)))
- (result-printer result seconds stream)))
-