X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=suite.lisp;fp=suite.lisp;h=046b61ad67543f68a00d6422c9ad8cb343c5d431;hb=318cda1a328e9d99af2270c73cb13262e485a1ff;hp=0000000000000000000000000000000000000000;hpb=bee53ea40ad9caeeed1e7392d1f59127df7512ac;p=xlunit.git

diff --git a/suite.lisp b/suite.lisp
new file mode 100644
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)))
+