X-Git-Url: http://git.kpe.io/?p=xlunit.git;a=blobdiff_plain;f=suite.lisp;h=254211748790100ea6151fac9e5f4b715de0f92c;hp=4a64425c9c89a870e3f5dbb96da25195c5552c83;hb=HEAD;hpb=53e193feda5d4cb757ef13d622fac03cf99178a2 diff --git a/suite.lisp b/suite.lisp index 4a64425..2542117 100644 --- a/suite.lisp +++ b/suite.lisp @@ -2,132 +2,81 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; ID: $Id: suite.lisp,v 1.3 2003/08/04 16:13:58 kevin Exp $ +;;;; ID: $Id$ ;;;; 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 - :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 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 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-'. 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) - (ignore-errors - (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))) -;---------------------------------------------------------------------- -; macro def-test-method -; -; Creates the representation of a test method (included within a -; test-case object) and add it to the corresponding suite class. -; => clos version of the pluggable selector pattern -; -; use: (def-test-method test-assert-false (clos-unit-test) -; (assert-true (eql (+ 1 2) 4) "comment")) -; -; new: it calls the textui-test-run function during eval, so to -; 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)))) - - -;;; 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))) - + (add-test (suite ,instance-name) ,instance-name) + (when ,run + (textui-test-run ,instance-name))))