From 318cda1a328e9d99af2270c73cb13262e485a1ff Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Mon, 4 Aug 2003 12:01:54 +0000
Subject: [PATCH] r5449: *** empty log message ***

---
 assert.lisp      |  43 ++++++++++++++++
 debian/changelog |   6 +++
 debian/rules     |   2 +-
 fixture.lisp     | 124 +++++++++++++++++++++++++++++++++++++++++++++++
 package.lisp     |  37 ++++++++------
 printer.lisp     |  46 ++++++++++++++++++
 result.lisp      |  42 ++++++++++++++++
 suite.lisp       | 124 +++++++++++++++++++++++++++++++++++++++++++++++
 tests.lisp       |  60 +++++++++++------------
 xlunit.asd       |  26 ++++++----
 10 files changed, 454 insertions(+), 56 deletions(-)
 create mode 100644 assert.lisp
 create mode 100644 fixture.lisp
 create mode 100644 printer.lisp
 create mode 100644 result.lisp
 create mode 100644 suite.lisp

diff --git a/assert.lisp b/assert.lisp
new file mode 100644
index 0000000..8307e2f
--- /dev/null
+++ b/assert.lisp
@@ -0,0 +1,43 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:     assert.lisp
+;;;; Purpose:  Assert functions for XLUnit
+;;;; Author:   Kevin Rosenberg
+;;;;
+;;;; $Id: assert.lisp,v 1.1 2003/08/04 12:01:54 kevin Exp $
+;;;; *************************************************************************
+
+(in-package #:xlunit)
+
+
+;;; Assertions
+
+(define-condition test-failure-condition (simple-condition) 
+  ((msg :initform nil :initarg :msg :accessor msg))
+  (:documentation "Base class for all test failures."))
+
+
+(defun failure (format-str &rest args)
+  "Signal a test failure and exit the test."
+  (signal 'test-failure-condition
+	  :format-control format-str
+	  :format-arguments args))
+
+(defmacro test-assert (test &optional msg)
+  `(unless ,test
+    (failure "Test assertion: ~s" ',test)))
+
+(defun assert-equal (v1 v2 &optional msg)
+  (unless (equal v1 v2)
+    (failure "Test equal: ~s ~s" v1 v2)))
+
+(defun assert-true (v &optional msg)
+  (unless v
+    (failure "Test true: ~s [~A]" v (if msg msg ""))))
+
+(defun assert-false (v &optional msg)
+  (when v
+    (failure "Test false ~A" (if msg msg ""))))
+
diff --git a/debian/changelog b/debian/changelog
index 67f37f8..b4dd854 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+cl-xlunit (0.2.0-1) unstable; urgency=low
+
+  * New version
+
+ -- Kevin M. Rosenberg <kmr@debian.org>  Mon,  4 Aug 2003 05:35:35 -0600
+
 cl-xlunit (0.1.0-1) unstable; urgency=low
 
   * Initial upload
diff --git a/debian/rules b/debian/rules
index 3e2f340..426d6e5 100755
--- a/debian/rules
+++ b/debian/rules
@@ -52,7 +52,7 @@ binary-arch: build install
 	dh_testroot
 #	dh_installdebconf	
 	dh_installdocs 
-	dh_installexamples examples.lisp
+	dh_installexamples example.lisp
 #	dh_installmenu
 #	dh_installlogrotate
 #	dh_installemacsen
diff --git a/fixture.lisp b/fixture.lisp
new file mode 100644
index 0000000..8408cc8
--- /dev/null
+++ b/fixture.lisp
@@ -0,0 +1,124 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:        fixture.lisp
+;;;; Purpose:     eXtreme Lisp Test Suite
+;;;; Authors:     Kevin Rosenberg and Craig Brozefsky
+;;;;
+;;;; $Id: fixture.lisp,v 1.1 2003/08/04 12:01:54 kevin Exp $
+;;;; *************************************************************************
+
+(in-package #:xlunit)
+
+
+(defclass test-fixture ()
+  ((test-thunk
+    :initarg :test-thunk :reader test-thunk
+    :initform 'perform-test
+    :documentation
+    "A thunk or symbol which will be applied to this instance, a
+test-case, to perform that test-case. Defaults to 'perform-test")
+   (test-name
+    :initarg :test-name
+    :reader test-name
+    :documentation
+    "The name of this test-case, used in reports.")
+   (test-description
+    :initarg :description
+    :reader description
+    :documentation
+    "Short description of this test-case, uses in reports"))
+  (:documentation
+   "Base class for test-fixtures.  Test-cases are instances of test-fixtures."))
+
+(defgeneric setup (test)
+  (:documentation
+   "Method called before performing a test, should set up the
+environment the test-case needs to operate in."))
+
+(defmethod setup ((test test-fixture))
+  t)
+
+(defgeneric teardown (test)
+  (:documentation
+   "Method called after performing a test.  Should reverse everything
+that the setup method did for this instance."))
+
+(defmethod teardown ((test test-fixture))
+  t)
+
+
+(defmacro handler-case-if (test form &body cases)
+  `(if ,test
+       (handler-case
+        ,form
+	,@cases)
+     ,form))
+
+(defmacro unwind-protect-if (test protected cleanup)
+  `(if ,test
+       (unwind-protect
+	   ,protected
+	 ,cleanup)
+     (progn ,protected ,cleanup)))
+
+
+(defmethod run-test ((test test-fixture)
+		     &key (result (make-instance 'test-result))
+		     (handle-errors t))
+  "Perform the test represented by the given test-case or test-suite.
+Returns one or more test-result objects, one for each test-case
+performed."
+  (incf (test-count result))
+  (with-slots (failures errors) result
+    (unwind-protect-if handle-errors
+	(handler-case-if handle-errors
+	 (let ((res (progn (setup test)
+			   (funcall (test-thunk test) test))))
+	   (if (typep res 'test-failure-condition)
+	       (push (make-instance 'test-failure
+		       :failed-test test
+		       :thrown-condition res)
+		     failures)))
+	 (test-failure-condition (failure)
+				 (push (make-instance 'test-failure
+					 :failed-test test
+					 :thrown-condition failure)
+				       failures))
+	 (error (err)
+		(push (make-instance 'test-failure 
+			:failed-test test 
+			:thrown-condition err)
+		      errors)))
+	(if handle-errors
+	    (handler-case
+		(teardown test)
+	      (error (err)
+		(push 
+		 (make-instance 'test-failure
+		   :failed-test test :thrown-condition err)
+		 errors)))
+	  (teardown test))))
+  result)
+
+
+(defun make-test (fixture name &key test-thunk test-suite description)
+  "Create a test-case which is an instance of FIXTURE.  TEST-THUNK is
+the method that will be invoked when perfoming this test, and can be a
+symbol or a lambda taking a single argument, the test-fixture
+instance.  DESCRIPTION is obviously what it says it is."
+  (let ((newtest (make-instance fixture
+		   :test-name (etypecase name
+				(symbol
+				 (string-downcase (symbol-name name)))
+				(string
+				 name))
+		   :test-thunk 
+		   (if(and (symbolp name) (null test-thunk))
+		       name
+		     test-thunk)
+		   :description description)))
+       (if test-suite (add-test newtest test-suite))
+       newtest))
+
diff --git a/package.lisp b/package.lisp
index fc7291a..4b51cf5 100644
--- a/package.lisp
+++ b/package.lisp
@@ -6,7 +6,7 @@
 ;;;; Purpose:     Package definition for XLTEST
 ;;;; Authors:     Kevin Rosenberg and Craig Brozefsky
 ;;;;
-;;;; $Id: package.lisp,v 1.3 2003/08/04 09:50:33 kevin Exp $
+;;;; $Id: package.lisp,v 1.4 2003/08/04 12:01:54 kevin Exp $
 ;;;; *************************************************************************
 
 (in-package #:cl-user)
@@ -16,13 +16,24 @@
   (:nicknames #:xlunit #:xptest)
   (:export
      ;;; Framework classes
+   
+   ;; fixture
+   #:test-fixture
    #:setup
    #:teardown
-   #:perform-test
-   #:test-failure
-   #:failure
    #:run-test
    #:make-test
+
+   ;; assert
+   #:assert-equal
+   #:assert-true
+   #:assert-false
+   #:test-assert
+   #:test-failure
+   #:failure
+
+   ;; suite.lisp
+   #:text-testrunner
    #:make-test-suite
    #:setup-testsuite-named
    #:teardown-testsuite-named
@@ -30,16 +41,14 @@
    #:test-named
    #:remove-test
    #:tests
-   #:test-result
-   #:report-result
-   #:make-test-suite-for-fixture
-   #:assert-equal
-   #:assert-true
-   #:assert-false
-   #:test-assert
-   #:test-fixture
-   #:text-testrunner
+   
+   ;; printer.lisp
    #:summary
+   
+   ;; result.lisp
+   #:test-result
+   #:make-test-result
+   #:was-successful
    )
-  (:documentation "This is the XP TestSuite Framework."))
+  (:documentation "This is the XLUnit Framework."))
 
diff --git a/printer.lisp b/printer.lisp
new file mode 100644
index 0000000..16f1bdb
--- /dev/null
+++ b/printer.lisp
@@ -0,0 +1,46 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:        printer.lisp
+;;;; Purpose:     Printer functions for XLUnit
+;;;; Authors:     Kevin Rosenberg
+;;;;
+;;;; $Id: printer.lisp,v 1.1 2003/08/04 12:01:54 kevin Exp $
+;;;; *************************************************************************
+
+(in-package #:xlunit)
+
+
+(defun result-printer (result seconds stream)
+  (format stream "~&Time: ~D~%~%" (coerce seconds 'float))
+  (print-defects (test-errors result) "error" stream)
+  (print-defects (test-failures result) "failure" stream)
+  (if (was-successful result)
+      (format stream "OK (~D tests)~%" (test-count result))
+    (progn
+      (format stream "~%FAILURES!!!~%")
+      (format stream "Tests run: ~D, Failures: ~D, Errors: ~D~%"
+	      (test-count result) (length (test-failures result))
+	      (length (test-errors result))))))
+
+(defun print-defects (defects type stream)
+  (when defects
+    (let ((count (length defects)))
+      (if (= count 1)
+	  (format stream "~&There was ~D ~A:~%" count type)
+	(format stream "~&There were ~D ~As:~%" count type))
+      (dotimes (i count)
+	(let ((defect (nth i defects)))
+	  (format stream "~&~D) ~A " i (class-name
+					(class-of (failed-test defect))))
+	  (apply #'format stream (simple-condition-format-control 
+				  (thrown-condition defect))
+		 (simple-condition-format-arguments 
+		  (thrown-condition defect)))
+	  (fresh-line stream))))))
+
+(defmethod summary ((result test-result))
+  (format nil "~D run, ~D erred, ~D failed"
+	  (test-count result) (length (test-errors result))
+	  (length (test-failures result))))
diff --git a/result.lisp b/result.lisp
new file mode 100644
index 0000000..ba95e4a
--- /dev/null
+++ b/result.lisp
@@ -0,0 +1,42 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:        result.lisp
+;;;; Purpose:     Result functions for XLUnit
+;;;; Authors:     Kevin Rosenberg
+;;;;
+;;;; $Id: result.lisp,v 1.1 2003/08/04 12:01:54 kevin Exp $
+;;;; *************************************************************************
+
+(in-package #:xlunit)
+
+
+(defclass test-result ()
+  ((test :initarg :test :reader result-test)
+   (count :initform 0 :accessor test-count)
+   (failures :initarg :failures :reader test-failures :initform nil)
+   (errors :initarg :errors :reader test-errors :initform nil))
+  (:documentation "The result of applying a test"))
+
+
+(defun make-test-result ()
+  (make-instance 'test-result))
+
+(defclass test-failure ()
+  ((failed-test :initarg :failed-test :reader failed-test)
+   (thrown-condition :initarg :thrown-condition :reader thrown-condition)))
+
+(defmethod is-failure ((failure test-failure))
+  (typep (thrown-condition failure) 'test-failure-condition))
+
+(defmethod print-object ((obj test-failure) stream)
+  (print-unreadable-object (obj stream :type t :identity nil)
+    (format stream "~A: " (failed-test obj))
+    (apply #'format stream 
+	   (simple-condition-format-control (thrown-condition obj))
+	   (simple-condition-format-arguments (thrown-condition obj)))))
+
+(defmethod was-successful ((result test-result))
+  (and (null (test-failures result))
+       (null (test-errors result))))
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)))
+
diff --git a/tests.lisp b/tests.lisp
index 101125a..ef8ed7c 100644
--- a/tests.lisp
+++ b/tests.lisp
@@ -7,7 +7,7 @@
 ;;;; Author:     Kevin Rosenberg
 ;;;;
 ;;;; Put in public domain by Kevin Rosenberg
-;;;; $Id: tests.lisp,v 1.3 2003/08/04 09:50:33 kevin Exp $
+;;;; $Id: tests.lisp,v 1.4 2003/08/04 12:01:54 kevin Exp $
 ;;;; *************************************************************************
 
 (defpackage #:xlunit-tests
@@ -15,10 +15,11 @@
 
 (in-package #:xlunit-tests)
 
+
+;; Helper test fixture
 (defclass was-run (test-fixture)
   ((log :accessor ws-log)))
 
-
 (defmethod setup ((self was-run))
   (setf (ws-log self) "setup "))
 
@@ -34,21 +35,19 @@
 (defmethod test-error-method ((self was-run))
   (error "Err"))
 
-(defclass test-case-test (test-fixture)
-  ((result :accessor result)))
+;;; Main test fixture
 
-(defmethod setup ((self test-case-test))
-  (setf (result self) (make-instance 'test-result)))
+(defclass test-case-test (test-fixture)
+  ())
 
 (defmethod test-template-method ((self test-case-test))
   (let ((test (make-test 'was-run 'test-method)))
-    (run-test test (result self))
+    (run-test test)
     (assert-equal (ws-log test) "setup test-method teardown ")))
 
 (defmethod test-result ((self test-case-test))
-  (let ((test (make-test 'was-run 'test-method)))
-    (run-test test (result self))
-    (assert-equal "1 run, 0 errored, 0 failed" (summary (result self)))))
+  (assert-equal "1 run, 0 erred, 0 failed" 
+		(summary (run-test (make-test 'was-run 'test-method)))))
 
 (defmethod test-thunk ((self test-case-test))
   (let ((test (make-test 'was-run '"Test Failure"
@@ -56,35 +55,34 @@
 			 (lambda (test) 
 			   (declare (ignore test))
 			   (assert-equal 10 10)))))
-    (run-test test (result self))
-    (assert-equal "1 run, 0 errored, 0 failed"
-		  (summary (result self)))))
+    (assert-equal "1 run, 0 erred, 0 failed"
+		  (summary (run-test test)))))
 
 (defmethod test-failed-result ((self test-case-test))
-  (let ((test (make-test 'was-run 'test-broken-method)))
-    (run-test test (result self))
-    (assert-equal "1 run, 0 errored, 1 failed"
-		  (summary (result self)))))
+  (assert-equal "1 run, 0 erred, 1 failed"
+		(summary (run-test
+			  (make-test 'was-run 'test-broken-method)))))
 
 (defmethod test-error-result ((self test-case-test))
-  (let ((test (make-test 'was-run 'test-error-method)))
-    (run-test test (result self))
-    (assert-equal "1 run, 1 errored, 0 failed"
-		  (summary (result self)))))
-
+  (assert-equal "1 run, 1 erred, 0 failed"
+		(summary (run-test
+			  (make-test 'was-run 'test-error-method)))))
+  
 (defmethod test-suite ((self test-case-test))
-  (let ((suite (make-test-suite "TestSuite")))
+  (let ((suite (make-test-suite "TestSuite"))
+	(result (make-test-result)))
     (add-test (make-test 'was-run 'test-method) suite)
     (add-test (make-test 'was-run 'test-broken-method) suite)
-    (run-test suite (result self)))
-  (assert-equal "2 run, 0 errored, 1 failed" 
-		(summary (result self))))
+    (run-test suite :result result)
+    (assert-equal "2 run, 0 erred, 1 failed" (summary result))))
 
 (defmethod test-dynamic-suite ((self test-case-test))
-  (let ((suite (make-test-suite 'was-run)))
-    (run-test suite (result self)))
-  (assert-equal "3 run, 1 errored, 1 failed" 
-		(summary (result self))))
+  (assert-equal "3 run, 1 erred, 1 failed" 
+		(summary (run-test (make-test-suite 'was-run)))))
 
-(text-testrunner (make-test-suite 'test-case-test))
+(text-testrunner (make-test-suite 'test-case-test) :handle-errors nil)
 
+(defun do-tests ()
+  (or (was-successful 
+       (run-test (make-test-suite 'test-case-test)))
+      (error "Failed tests")))
diff --git a/xlunit.asd b/xlunit.asd
index 30ca6f7..9cd8bdb 100644
--- a/xlunit.asd
+++ b/xlunit.asd
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Aug 2003
 ;;;;
-;;;; $Id: xlunit.asd,v 1.1 2003/08/04 09:51:36 kevin Exp $
+;;;; $Id: xlunit.asd,v 1.2 2003/08/04 12:01:54 kevin Exp $
 ;;;; *************************************************************************
 
 (defpackage #:xlunit-system (:use #:asdf #:cl))
@@ -17,23 +17,29 @@
   :name "xlunit"
   :author "Kevin Rosenberg based on work by Craig Brozensky"
   :maintainer "Kevin M. Rosenberg <kmr@debian.org>"
-  :licence "Public domain"
+  :licence "BSD"
   :description "Extreme Lisp Testing Suite"
-  :long-description "The XLUNIT package is toolkit for building test suites based on the XPTEST package by Craig Brozensky."
+  :long-description "The XLUnit package is toolkit for building test suites. It is based on the XPTest package by Craig Brozensky and the JUnit package by Kent Beck."
   
+  :serial t
   :components
   ((:file "package")
-   (:file "src" :depends-on ("package"))))
+   (:file "assert")
+   (:file "fixture")
+   (:file "suite")
+   (:file "result")
+   (:file "printer")
+   ))
 
 (defmethod perform ((o test-op) (c (eql (find-system 'xlunit))))
-  (oos 'load-op 'xlunit-tests)
-  (oos 'test-op 'xlunit-tests))
+  (oos 'load-op 'xlunit-tests :force t)
+  (oos 'test-op 'xlunit-tests :force t))
 
 (defsystem xlunit-tests
-  :depends-on (xlunit)
-  :components ((:file "tests")))
+    :depends-on (xlunit)
+    :components ((:file "tests")))
 
 (defmethod perform ((o test-op) (c (eql (find-system 'xlunit-tests))))
-  (or (funcall (intern (symbol-name #:do-tests)
-		       (find-package #:xlunit-tests)))
+  (or (funcall (intern (symbol-name '#:do-tests)
+		       (find-package '#:xlunit-tests)))
       (error "test-op failed")))
-- 
2.34.1