X-Git-Url: http://git.kpe.io/?p=xlunit.git;a=blobdiff_plain;f=suite.lisp;h=254211748790100ea6151fac9e5f4b715de0f92c;hp=e410b5daa958d8708d75e2ec9009f6280f2b17a0;hb=HEAD;hpb=8133177de9c5d202520bd83b5e797ef7a39942ad diff --git a/suite.lisp b/suite.lisp index e410b5d..2542117 100644 --- a/suite.lisp +++ b/suite.lisp @@ -2,121 +2,81 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; ID: $Id: suite.lisp,v 1.2 2003/08/04 12:16:13 kevin Exp $ +;;;; ID: $Id$ ;;;; Purpose: Suite functions for XLUnit ;;;; ;;;; ************************************************************************* (in-package #:xlunit) -(defclass test-suite () - ((name :initarg :name :reader test-suite-name) - (tests :initarg :tests :accessor tests-hash - :initform (make-hash-table :test 'equal)) +(defclass test-suite (test) + ((name :initform "" :initarg :name :reader test-suite-name) + (tests :initarg :tests :accessor tests :initform nil) (description :initarg :description :reader description - :initform "No description."))) + :initform "No description."))) +(defmacro get-suite (class-name) + `(suite (make-instance ',class-name))) -(defmethod setup-testsuite-named (name) - (declare (ignore name)) - t) -(defmethod teardown-testsuite-named (name) - (declare (ignore name)) - t) +(defmethod add-test ((ob test-suite) (new-test test)) + (remove-test new-test ob) + (setf (tests ob) (append (tests ob) (list new-test)))) -(defmethod run-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-test test :result result :handle-errors handle-errors)) - (teardown-testsuite-named (slot-value suite 'name)) - result) -(defmethod tests ((suite test-suite)) - (let ((tlist nil)) - (maphash #'(lambda (k v) - (declare (ignore k)) - (setf tlist (cons v tlist))) - (tests-hash suite)) - (reverse tlist))) +(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))) -(defun make-test-suite (name-or-fixture &optional description testspecs) - "Returns a new test-suite based on a name and TESTSPECS or a fixture -instance" - (etypecase name-or-fixture - (symbol - (make-test-suite-for-fixture (make-instance name-or-fixture))) - (string - (let ((suite (make-instance 'test-suite :name name-or-fixture - :description description))) - (dolist (testspec testspecs) - (add-test (apply #'make-test testspec) suite)) - suite)))) - - -(defmethod add-test ((test test-fixture) (suite test-suite)) - (setf (gethash (test-name test) (tests-hash suite)) test)) - -(defmethod add-test ((test test-suite) (suite test-suite)) - (setf (gethash (test-suite-name test) (tests-hash suite)) test)) - -(defmethod remove-test ((test test-fixture) (suite test-suite)) - (remhash (test-name test) (tests-hash suite))) - -(defmethod remove-test ((test test-suite) (suite test-suite)) - (remhash (test-suite-name test) (tests-hash suite))) - -(defmethod test-named ((name string) (suite test-suite)) - (gethash name (tests-hash 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 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 'test-name) - (test-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-'. This is used to dynamically generate a list of tests for a fixture." (let ((res) - (package (symbol-package (class-name (class-of instance))))) + (package (symbol-package (class-name (class-of instance))))) (do-symbols (s package) (when (and (> (length (symbol-name s)) 5) - (string-equal "test-" (subseq (symbol-name s) 0 5)) - (fboundp s) - (typep (symbol-function s) 'generic-function) - (plusp (length (compute-applicable-methods - (ensure-generic-function s) - (list instance))))) - (push s res))) + (string-equal "test-" (subseq (symbol-name s) 0 5)) + (fboundp s) + (typep (symbol-function s) 'generic-function) + (ignore-errors + (plusp (length (compute-applicable-methods + (ensure-generic-function s) + (list instance)))))) + (push s res))) (nreverse res))) -;;; Test Runners - -(defmethod text-testrunner ((suite test-suite) &key (stream t) - (handle-errors t)) - (let* ((start-time (get-internal-real-time)) - (result (run-test suite :handle-errors handle-errors)) - (seconds (/ (- (get-internal-real-time) start-time) - internal-time-units-per-second))) - (result-printer result seconds stream))) - +(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 ,instance-name) + #'(lambda() ,@method-body)) + (add-test (suite ,instance-name) ,instance-name) + (when ,run + (textui-test-run ,instance-name))))