r5449: *** empty log message ***

[xlunit.git] / suite.lisp

diff --git a/suite.lisp b/suite.lisp
new file mode 100644 (file)
index 0000000..046b61a
--- /dev/null
+++ b/suite.lisp
@@ -0,0 +1,124 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:        suite.lisp
+;;;; Purpose:     Suite functions for XLUnit
+;;;; Authors:     Kevin Rosenberg and Craig Brozefsky
+;;;;
+;;;; $Id: suite.lisp,v 1.1 2003/08/04 12:01:54 kevin Exp $
+;;;; *************************************************************************
+
+(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))
+   (description :initarg :description :reader description
+               :initform "No description.")))
+
+
+(defmethod setup-testsuite-named (name)
+  (declare (ignore name))
+  t)
+
+(defmethod teardown-testsuite-named (name)
+  (declare (ignore name))
+  t)
+
+(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)))
+
+
+(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)))
+
+
+;; 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)))))
+    (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)))
+    (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)))
+