From e2bf8174193c9acc013b8bbbc116b7e7acc86526 Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Fri, 8 Aug 2003 00:57:20 +0000
Subject: [PATCH] r5467: *** empty log message ***

---
 assert.lisp  |  34 +++++-
 package.lisp |  16 +--
 src.lisp     | 305 ---------------------------------------------------
 tcase.lisp   |  27 +----
 tests.lisp   |  36 +++++-
 xlunit.asd   |   3 +-
 6 files changed, 73 insertions(+), 348 deletions(-)
 delete mode 100644 src.lisp

diff --git a/assert.lisp b/assert.lisp
index d1d7792..f9ddec2 100644
--- a/assert.lisp
+++ b/assert.lisp
@@ -2,7 +2,7 @@
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
-;;;; ID:       $Id: assert.lisp,v 1.8 2003/08/06 14:51:01 kevin Exp $
+;;;; ID:       $Id: assert.lisp,v 1.9 2003/08/08 00:57:20 kevin Exp $
 ;;;; Purpose:  Assert functions for XLUnit
 ;;;;
 ;;;; *************************************************************************
@@ -48,9 +48,31 @@
   `(when ,v
      (failure-message ,message "Assert false: ~S" ',v)))
 
-(defmacro assert-condition (condition v &optional message)
-  
-  )
+(defmacro assert-condition (condition forms &optional message)
+  (let ((cond (gensym "COND-")))
+    `(handler-case
+	 (progn
+	   ,forms
+	   (values))
+       (t (,cond)
+	 (when (and (typep ,cond 'serious-condition)
+		    (not (typep ,cond ,condition)))
+	   (failure-message 
+	    ,message 
+	    "Assert condition ~A, but signaled condition ~A"
+	    ,condition ,cond)))
+       (:no-error ()
+	 (failure-message ,message
+			  "Assert condition ~A, but no condition signaled"
+			  ,condition)))))
 
-(defmacro assert-not-condition (condition v &optional message)
-  )
+(defmacro assert-not-condition (condition forms &optional message)
+  (let ((cond (gensym "COND-")))
+    `(handler-case
+	 (progn
+	   ,forms
+	   (values))
+       (serious-condition (,cond)
+	 (unless (typep ,cond ,condition)
+	   (failure-message ,message "Assert not condition ~A"
+			    ,condition))))))
diff --git a/package.lisp b/package.lisp
index 2f0da68..2bdfee5 100644
--- a/package.lisp
+++ b/package.lisp
@@ -2,10 +2,10 @@
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
-;;;; ID:      $Id: package.lisp,v 1.10 2003/08/06 14:15:32 kevin Exp $
+;;;; ID:      $Id: package.lisp,v 1.11 2003/08/08 00:57:20 kevin Exp $
 ;;;; Purpose: Package definition for XLUnit
 ;;;;
-;;;; $Id: package.lisp,v 1.10 2003/08/06 14:15:32 kevin Exp $
+;;;; $Id: package.lisp,v 1.11 2003/08/08 00:57:20 kevin Exp $
 ;;;; *************************************************************************
 
 (in-package #:cl-user)
@@ -24,14 +24,14 @@
    #:make-test
 
    ;; assert
+   #:assert-equal
    #:assert-true
    #:assert-false
-   #:assert-equal
-   #:assert-eql
-   #:assert-not-eql
-   #:assert-condition
-   #:assert-not-condition
-   #:test-failure
+   #:test
+   #:test-error
+   #:test-no-error
+   #:test-warning
+   #:test-no-warning
    #:failure
 
    ;; suite.lisp
diff --git a/src.lisp b/src.lisp
deleted file mode 100644
index 4896067..0000000
--- a/src.lisp
+++ /dev/null
@@ -1,305 +0,0 @@
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name:        src.lisp
-;;;; Purpose:     eXtreme Lisp Test Suite
-;;;; Authors:     Kevin Rosenberg and Craig Brozefsky
-;;;;
-;;;; $Id: src.lisp,v 1.3 2003/08/04 09:50:33 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."))
-
-(defmethod setup ((test test-fixture))
-  "Method called before performing a test, should set up the
-environment the test-case needs to operate in."
-  t)
-
-(defmethod teardown ((test test-fixture))
-  "Method called after performing a test.  Should reverse everything that the
-setup method did for this instance."
-  t)
-
-(define-condition test-failure-condition (simple-condition) 
-  ()
-  (:documentation "Base class for all test failures."))
-
-(defclass test-failure ()
-  ((failed-test :initarg :failed-test :reader failed-test)
-   (thrown-condition :initarg :thrown-condition :reader thrown-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 is-failure ((failure test-failure))
-  (typep (thrown-condition failure) 'test-failure-condition))
-
-(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 ""))))
-
-
-(defmethod perform-test ((test test-fixture))
-  "Default method for performing tests upon a 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)))
-
-(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"))
-
-(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) (result test-result)
-		     &key (handle-errors t))
-  (setup-testsuite-named (slot-value suite 'name))
-  (dolist (test (tests suite))
-    (run-test test result :handle-errors handle-errors))
-  (teardown-testsuite-named (slot-value suite 'name))
-  (values))
-
-(defmethod run-test ((test test-fixture) result &key (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))))
-  (values))
-
-
-(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 (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))
-	   
-(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)))
-
-(defmethod was-successful ((result test-result))
-  (and (null (test-failures result))
-       (null (test-errors result))))
-
-(defmethod text-testrunner ((suite test-suite) &key (stream t)
-						    (handle-errors t))
-  (let ((result (make-instance 'test-result))
-	(start-time (get-internal-real-time)))
-    (run-test suite result :handle-errors handle-errors)
-    (let ((seconds (/ (- (get-internal-real-time) start-time)
-		      internal-time-units-per-second)))
-      (result-printer result seconds stream))))
-
-(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 errored, ~D failed"
-	  (test-count result) (length (test-errors result))
-	  (length (test-failures result))))
-
-;;; Dynamic test suite addition by Kevin Rosenberg 8/2003
-
-(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)))
-
-
-
diff --git a/tcase.lisp b/tcase.lisp
index 4c13e1e..5761a9f 100644
--- a/tcase.lisp
+++ b/tcase.lisp
@@ -2,7 +2,7 @@
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
-;;;; ID:      $Id: tcase.lisp,v 1.5 2003/08/06 14:51:01 kevin Exp $
+;;;; ID:      $Id: tcase.lisp,v 1.6 2003/08/08 00:57:20 kevin Exp $
 ;;;; Purpose: Test fixtures for XLUnit
 ;;;;
 ;;;; *************************************************************************
@@ -72,35 +72,18 @@ that the setup method did for this instance."))
   (set-up test)
   (unwind-protect
       (run-test test)
-    (tear-down test))
-  (values))
+    (tear-down test)))
 
 (defmethod run-test ((test test-case))
     (funcall (method-body test)))
 
-(defmethod run-protected ((test test-case) res 
-			  &key (handle-errors t) test-condition)
+(defmethod run-protected ((test test-case) res &key (handle-errors t))
   (if handle-errors
       (handler-case
 	  (run-base test)
 	(assertion-failed (condition)
 	  (add-failure res test condition))
-	(t (condition)
-	  (when (and test-condition
-		     (not (typep condition test-condition)))
-	    (add-failure res test
-			 (make-instance 'assertion-failed
-			   :format-control
-			   "Assert condition ~A, but condition ~A signaled"
-			   :format-arguments
-			   (list test-condition condition)))))
 	(serious-condition (condition)
-	  (add-error res test condition))
-	(:no-error ()
-	  (when test-condition
-	    (add-failure res test
-			 (make-instance 'assertion-failed
-			   :format-control "Assert condition ~A, but no condition signaled"
-			   :format-arguments (list test-condition))))))
-    (run-base test))
+	  (add-error res test condition)))
+      (run-base test))
   res)
diff --git a/tests.lisp b/tests.lisp
index 60daebf..8042fe8 100644
--- a/tests.lisp
+++ b/tests.lisp
@@ -2,7 +2,7 @@
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
-;;;; Id:      $Id: tests.lisp,v 1.13 2003/08/06 14:51:01 kevin Exp $
+;;;; Id:      $Id: tests.lisp,v 1.14 2003/08/08 00:57:20 kevin Exp $
 ;;;; Purpose: Self Test suite for XLUnit
 ;;;;
 ;;;; *************************************************************************
@@ -13,6 +13,9 @@
   (:export #:do-tests))
 (in-package #:xlunit-tests)
 
+(define-condition test-condition (error)
+  ())
+
 
 ;; Helper test fixture
 
@@ -43,6 +46,13 @@
 (def-test-method test-error-method ((self was-run) :run nil)
     (error "Err"))
 
+(def-test-method test-condition-without-cond ((self was-run) :run nil)
+  (assert-condition 'error (list 'no-error)))
+
+(def-test-method test-not-condition-with-cond ((self was-run) :run nil)
+  (assert-not-condition 'test-condition 
+			(signal 'test-condition)))
+
 
 ;;; Second helper test case
 
@@ -113,13 +123,29 @@
   (assert-equal "2 run, 0 erred, 0 failed" 
 		(summary (run (get-suite test-two-cases)))))
 
-(define-condition test-condition (error)
-  ())
-
 (def-test-method test-condition ((self test-case-test) :run nil)
   (assert-condition 
-   test-condition 
+   'test-condition 
    (error (make-instance 'test-condition))))
+
+(def-test-method test-condition-without-cond ((self test-case-test) 
+					      :run nil)
+  (assert-equal "1 run, 0 erred, 1 failed"
+		(summary (run
+			  (named-test 'test-condition-without-cond
+				      (get-suite was-run))))))
+  
+(def-test-method test-not-condition ((self test-case-test) :run nil)
+  (assert-not-condition 
+   'test-condition 
+   (progn)))
+
+(def-test-method test-not-condition-with-cond ((self test-case-test) 
+					      :run nil)
+  (assert-equal "1 run, 0 erred, 1 failed"
+		(summary (run
+			  (named-test 'test-not-condition-with-cond
+				      (get-suite was-run))))))
 		    
 (textui-test-run (get-suite test-case-test))
 
diff --git a/xlunit.asd b/xlunit.asd
index dbbb0ed..1e9d6c2 100644
--- a/xlunit.asd
+++ b/xlunit.asd
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Aug 2003
 ;;;;
-;;;; $Id: xlunit.asd,v 1.7 2003/08/06 12:22:05 kevin Exp $
+;;;; $Id: xlunit.asd,v 1.8 2003/08/08 00:57:20 kevin Exp $
 ;;;; *************************************************************************
 
 (defpackage #:xlunit-system (:use #:asdf #:cl))
@@ -22,7 +22,6 @@
   :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."
 
   :properties ((#:author-email . "kevin@rosenberg.net")
-	       (#:date . "Summer 2003")
 	       ((#:albert #:output-dir) . "albert-docs/")
 	       ((#:albert #:formats) . ("docbook"))
 	       ((#:albert #:docbook #:template) . "book")
-- 
2.34.1