r5455: *** empty log message ***

diff --git a/LICENSE b/LICENSE
index 8ba724ee58d2fc1092490ef5c3870f16ea3f96b9..dfdbaca6fa692045a6441df4fdd127ad41b7e834 100644 (file)
--- a/LICENSE
+++ b/LICENSE
@@ -1,4 +1,6 @@
-Copyright (c) 2003 Kevin M. Rosenberg
+Copyright (c) 2003 Kevin M. Rosenberg <kevin@rosenberg.net>
+Copyright (C) 2002 Canoo Engineering AG <sandro.pedrazzini_at_canoo.com>
+
 All rights reserved.
 
 Redistribution and use in source and binary forms, with or without

diff --git a/Makefile b/Makefile
new file mode 100644 (file)
index 0000000..0c6e148
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,9 @@
+all:
+
+
+.PHONY: clean
+clean:
+       @rm -rf .bin 
+       @rm -f *.ufsl *.fsl *.fas *.x86f *.sparcf *.fasl* *.lib
+       @rm -f *~ *.bak *.orig *.err \#*\# .#*
+

diff --git a/README b/README
index a2079b71d630bd7e2d99ad20b3d1ad9a4c6b27a9..7fceecbc8c4992de83f21b23cba7773927f75095 100644 (file)
--- a/README
+++ b/README
@@ -1,10 +1,8 @@
 XLUnit provides a unit testing package for Common Lisp.  It it based
-on the XPTest package by OnShore development, but is rewritten to be
-closer in usage to the JUnit package.
-
-XLUnit it is designed to be used with significantly less overhead on
-the part of the test author compared to XPTest. Most powerfully,
-XLUnit can create dynamic test suites based on defined methods.
+on the 3 similar packages:
+   JUnit by Kent Beck
+   XPTest package by OnShore development
+   CLOS-unit by Sandro Pedrazzini
 
 XLUnit comes with its own test suite (tests.lisp) along with an
 example file (example.lisp).

diff --git a/debian/changelog b/debian/changelog
index b4dd85464f6f4811a4aa90b3af43c1e3ba1b1a88..b3fd5b8c741cca98b7b69672a412bcf8e624aa8a 100644 (file)
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+cl-xlunit (0.5.0-1) unstable; urgency=low
+
+  * New usptream
+
+ -- Kevin M. Rosenberg <kmr@debian.org>  Mon,  4 Aug 2003 13:39:48 -0600
+
 cl-xlunit (0.2.0-1) unstable; urgency=low
 
   * New version

diff --git a/debian/copyright b/debian/copyright
index 85f2d571429933f0932c445271bb1c55e8a8f6c5..cb106ad9a696a3224a24aeeebb6774f693ad8338 100644 (file)
--- a/debian/copyright
+++ b/debian/copyright
@@ -8,7 +8,9 @@ Debian Maintainer:  Kevin M. Rosenberg <kmr@debian.org>
 
 Upstream Copyright Statement
 ============================
-Copyright (c) 2003 Kevin M. Rosenberg
+Copyright (c) 2003 Kevin M. Rosenberg <kevin@rosenberg.net>
+Copyright (C) 2002 Canoo Engineering AG <sandro.pedrazzini_at_canoo.com>
+
 All rights reserved.
 
 Redistribution and use in source and binary forms, with or without

diff --git a/example.lisp b/example.lisp
index 837906b713cee0fa2945501a33430bd1f6697bab..4a89aec87074524355632b0c8024fff9d10b57e6 100644 (file)
--- a/example.lisp
+++ b/example.lisp
@@ -2,7 +2,7 @@
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
-;;;; ID:      $Id: example.lisp,v 1.6 2003/08/04 17:04:49 kevin Exp $
+;;;; ID:      $Id: example.lisp,v 1.7 2003/08/04 19:31:34 kevin Exp $
 ;;;; Purpose: Example file for XLUnit
 ;;;;
 ;;;; *************************************************************************
@@ -32,19 +32,20 @@
   (setf (numbera tcase) 2)
   (setf (numberb tcase) 3))
 
-(def-test-method test-addition ((test math-test-case))
+
+(def-test-method (test-addition test math-test-case :run nil)
   (let ((result (+ (numbera test) (numberb test))))
     (assert-true (= result 5))))
 
-(def-test-method test-subtraction ((test math-test-case))
+(def-test-method (test-subtraction test math-test-case :run nil)
   (let ((result (- (numberb test) (numbera test))))
     (assert-equal result 1)))
 
 ;;; This method is meant to signal a failure
-(def-test-method test-subtraction-2 ((test math-test-case))
+(def-test-method (test-subtraction-2 test math-test-case :run nil)
   (let ((result (- (numbera test) (numberb test))))
     (assert-equal result 1)))
 
 ;;;; Finally we can run our test suite and see how it performs.
-(textui-test-run (make-instance 'math-test-case))
+(textui-test-run (get-suite math-test-case))
 

diff --git a/package.lisp b/package.lisp
index ffaa50de62d978d82ca7451f5c379b708cfd351d..68562f23704ce4ffe1303966f09504b7029486d3 100644 (file)
--- a/package.lisp
+++ b/package.lisp
@@ -2,10 +2,10 @@
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
-;;;; ID:      $Id: package.lisp,v 1.7 2003/08/04 17:04:49 kevin Exp $
+;;;; ID:      $Id: package.lisp,v 1.8 2003/08/04 19:31:34 kevin Exp $
 ;;;; Purpose: Package definition for XLUnit
 ;;;;
-;;;; $Id: package.lisp,v 1.7 2003/08/04 17:04:49 kevin Exp $
+;;;; $Id: package.lisp,v 1.8 2003/08/04 19:31:34 kevin Exp $
 ;;;; *************************************************************************
 
 (in-package #:cl-user)
@@ -37,9 +37,12 @@
    #:setup-testsuite-named
    #:teardown-testsuite-named
    #:add-test
-   #:test-named
+   #:named-test
    #:remove-test
    #:tests
+   #:get-suite
+   #:test-suite
+   #:run-on-test-results
    
    ;; printer.lisp
    #:summary

diff --git a/printer.lisp b/printer.lisp
index c89bfff0b722706124850b213fa5959d121e68c1..3637ff454f4b1c49e069a21f676e55d19040fa82 100644 (file)
--- a/printer.lisp
+++ b/printer.lisp
@@ -2,7 +2,7 @@
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
-;;;; ID:      $Id: printer.lisp,v 1.4 2003/08/04 17:04:49 kevin Exp $
+;;;; ID:      $Id: printer.lisp,v 1.5 2003/08/04 19:31:34 kevin Exp $
 ;;;; Purpose: Printer functions for XLUnit
 ;;;;
 ;;;; *************************************************************************
@@ -41,7 +41,8 @@
       (let ((i 1))
         (mapc #'(lambda (single-error)
                   (format (ostream ob) "~a) ~a: ~a~%" i
-                          (name (car single-error)) (cdr single-error))
+                          (name (failed-test single-error))
+                         (thrown-condition single-error))
                   (incf i))
               errors)))))
 
@@ -53,8 +54,9 @@
         (format (ostream ob) "~%There were ~a failures:~%" (length failures)))
       (let ((i 1))
         (mapc #'(lambda (single-failure)
-                  (format (ostream ob) "~a) ~a: ~a~%" i (name (car single-failure))
-                          (or (message (cdr single-failure)) ""))
+                  (format (ostream ob) "~a) ~a: ~a~%" i 
+                         (name (failed-test single-failure))
+                          (or (message (thrown-condition single-failure)) ""))
                   (incf i))
               failures)))))
 

diff --git a/result.lisp b/result.lisp
index 1b7fd35984c9e60905f59664a427a5265ab8b7ff..eb49d0fc3773fb557c84e2cc581d918ff5066317 100644 (file)
--- a/result.lisp
+++ b/result.lisp
@@ -2,7 +2,7 @@
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
-;;;; ID:      $Id: result.lisp,v 1.5 2003/08/04 16:42:27 kevin Exp $
+;;;; ID:      $Id: result.lisp,v 1.6 2003/08/04 19:31:34 kevin Exp $
 ;;;; Purpose:  Result functions for XLUnit
 ;;;;
 ;;;; *************************************************************************
@@ -35,7 +35,6 @@
   res)
 
 (defmethod end-test ((tcase test) (res test-results))
-  (incf (run-tests res))
   (mapc (lambda (listener) (end-test listener tcase)) (listeners res))
   res)
 

diff --git a/suite.lisp b/suite.lisp
index 85cfcc6e2d40986119cca7c9d27012e940d8e356..f2394abecf65b106b677ce896e2776d0ba480dee 100644 (file)
--- a/suite.lisp
+++ b/suite.lisp
@@ -2,14 +2,14 @@
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
-;;;; ID:      $Id: suite.lisp,v 1.5 2003/08/04 17:04:49 kevin Exp $
+;;;; ID:      $Id: suite.lisp,v 1.6 2003/08/04 19:31:34 kevin Exp $
 ;;;; 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
@@ -19,65 +19,37 @@
   `(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-results))
-                    (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 new-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-'.
@@ -111,12 +83,15 @@ This is used to dynamically generate a list of tests for a fixture."
 ;      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))))
+     (add-test (suite ,instance-name) ,instance-name)
+     (when ,run 
+       (textui-test-run ,instance-name))))
                                                                                  

diff --git a/tcase.lisp b/tcase.lisp
index da0d8ded73b5868c510094dac93ab7dee05e7a38..3d68142afba33e56f6b0f2cee2fc6040f6dbc77d 100644 (file)
--- a/tcase.lisp
+++ b/tcase.lisp
@@ -2,7 +2,7 @@
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
-;;;; ID:      $Id: tcase.lisp,v 1.1 2003/08/04 17:04:49 kevin Exp $
+;;;; ID:      $Id: tcase.lisp,v 1.2 2003/08/04 19:31:34 kevin Exp $
 ;;;; Purpose: Test fixtures for XLUnit
 ;;;;
 ;;;; *************************************************************************
@@ -21,7 +21,7 @@
     :documentation
     "A function designator which will be applied to this instance
 to perform that test-case.")
-   (name :initarg :name :reader name
+   (name :initarg :name :reader name :initform ""
         :documentation "The name of this test-case, used in reports.")
    (description :initarg :description :reader description
                :documentation
@@ -56,9 +56,11 @@ that the setup method did for this instance."))
 (defmethod tear-down ((test test-case))
   )
 
-(defmethod run ((ob test-case))
-  (run-on-test-results ob (make-instance 'test-results)))
-   
+(defmethod run ((ob test) &key (handle-errors t))
+  "Generalized to work on test-case and test-suites"
+  (let ((res (make-test-results)))
+    (run-on-test-results ob res :handle-errors t)
+    res))
 
 (defmethod run-on-test-results ((test test-case) result
                                &key (handle-errors t))
@@ -73,7 +75,7 @@ that the setup method did for this instance."))
     (tear-down test)))
 
 (defmethod run-test ((test test-case))
-  (funcall (method-body test)))
+    (funcall (method-body test)))
 
 (defmethod run-protected ((test test-case) res &key (handle-errors t))
   (handler-case
@@ -85,63 +87,5 @@ that the setup method did for this instance."))
   res)
 
 
-(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-case)
-                    &key (result (make-instance 'test-results))
-                    (handle-errors t))
-  "Perform the test represented by the given test-case or test-suite.
-Returns a test-results object."
-  (incf (run-count result))
-  (with-slots (failures errors) result
-    (unwind-protect-if handle-errors
-       (handler-case-if handle-errors
-        (let ((res (progn (setup test)
-                          (funcall (method-body test) test))))
-          (when (typep res 'test-failure-condition)
-            (push (make-test-failure test res) failures)))
-        (test-failure-condition (failure)
-          (push (make-test-failure test failure) failures))
-        (error (err)
-          (push (make-test-failure test err) errors)))
-       
-       (if handle-errors
-           (handler-case
-               (teardown test)
-             (error (err)
-               (push (make-test-failure test err) errors)))
-           (teardown test))))
-  result)
-|#
-
-(defun make-test (fixture name &key method-body test-suite description)
-  "Create a test-case which is an instance of FIXTURE.  METHOD-BODY 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-case
-instance.  DESCRIPTION is obviously what it says it is."
-  (let ((newtest (make-instance fixture
-                  :name (etypecase name
-                               (symbol
-                                (string-downcase (symbol-name name)))
-                               (string
-                                name))
-                  :method-body 
-                  (if (and (symbolp name) (null method-body))
-                      name
-                    method-body)
-                  :description description)))
-    (when test-suite (add-test newtest test-suite))
-    newtest))
+
+

diff --git a/tests.lisp b/tests.lisp
index 9b519193f16ce4543b49a9a9feb3bd56f42cbb85..3b848a4c6ed29df24ccec98633065d29bb6ee25a 100644 (file)
--- a/tests.lisp
+++ b/tests.lisp
@@ -2,7 +2,7 @@
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
-;;;; Id:      $Id: tests.lisp,v 1.8 2003/08/04 17:04:50 kevin Exp $
+;;;; Id:      $Id: tests.lisp,v 1.9 2003/08/04 19:31:34 kevin Exp $
 ;;;; Purpose: Test suite for XLUnit
 ;;;;
 ;;;; *************************************************************************
@@ -19,20 +19,22 @@
 (defclass was-run (test-case)
   ((log :accessor ws-log)))
 
-(defmethod setup ((self was-run))
-  (setf (ws-log self) "setup "))
+(defmethod set-up ((self was-run))
+    (setf (ws-log self) "setup "))
 
-(defmethod teardown ((self was-run))
-  (setf (ws-log self) (concatenate 'string (ws-log self) "teardown ")))
+(defmethod tear-down ((self was-run))
+  (setf (ws-log self)
+       (concatenate 'string (ws-log self) "teardown ")))
 
-(defmethod test-method ((self was-run))
-  (setf (ws-log self) (concatenate 'string (ws-log self) "test-method ")))
+(def-test-method (test-method self was-run :run nil)
+    (setf (ws-log self) 
+      (concatenate 'string (ws-log self) "test-method ")))
 
-(defmethod test-broken-method ((self was-run))
-  (assert-equal pi (/ 22 7)))
+(def-test-method (test-broken-method self was-run :run nil)
+    (assert-equal pi (/ 22 7)))
 
-(defmethod test-error-method ((self was-run))
-  (error "Err"))
+(def-test-method (test-error-method self was-run :run nil)
+    (error "Err"))
 
 
 ;;; Main test fixture
@@ -40,50 +42,52 @@
 (defclass test-case-test (test-case)
   ())
 
-(defmethod test-template-method ((self test-case-test))
-  (let ((test (make-test 'was-run 'test-method)))
-    (run-test test)
+
+(def-test-method (test-template-method self test-case-test :run nil)
+  (let ((test (named-test 'test-method (get-suite was-run))))
+    (run test)
     (assert-equal (ws-log test) "setup test-method teardown ")))
 
-(defmethod test-results ((self test-case-test))
+(def-test-method (test-results self test-case-test :run nil)
   (assert-equal "1 run, 0 erred, 0 failed" 
-               (summary (run-test (make-test 'was-run 'test-method)))))
-
-(defmethod test-fn ((self test-case-test))
-  (let ((test (make-test 'was-run '"Test Failure"
-                        :test-fn
-                        (lambda (test) 
-                          (declare (ignore test))
-                          (assert-equal 10 10)))))
+               (summary (run (named-test 'test-method (get-suite was-run))))))
+
+(def-test-method (test-fn self test-case-test :run nil)
+  (let ((test (make-instance 'test-case :name 'test-fn
+                             :method-body
+                             (lambda () 
+                               (declare (ignore test))
+                               (assert-equal 10 10)))))
     (assert-equal "1 run, 0 erred, 0 failed"
-                 (summary (run-test test)))))
+                 (summary (run test)))))
 
-(defmethod test-failed-result ((self test-case-test))
+(def-test-method (test-failed-result self test-case-test :run nil)
   (assert-equal "1 run, 0 erred, 1 failed"
                (summary (run-test
-                         (make-test 'was-run 'test-broken-method)))))
+                         (named-test 'test-broken-method (get-suite was-run))))))
 
-(defmethod test-error-result ((self test-case-test))
-  (assert-equal "1 run, 1 erred, 0 failed"
-               (summary (run-test
-                         (make-test 'was-run 'test-error-method)))))
+(def-test-method (test-error-result self test-case-test :run nil)
+    (assert-equal "1 run, 1 erred, 0 failed"
+                 (summary (run-test
+                           (named-test 'test-error-method
+                                       (get-suite was-run))))))
   
-(defmethod test-suite ((self test-case-test))
-  (let ((suite (make-test-suite "TestSuite"))
+(def-test-method (test-suite self test-case-test :run nil)
+  (let ((suite (make-instance 'test-suite))
        (result (make-test-results)))
-    (add-test (make-test 'was-run 'test-method) suite)
-    (add-test (make-test 'was-run 'test-broken-method) suite)
-    (run-test suite :result result)
+    (add-test suite (named-test 'test-method (get-suite was-run)))
+    (add-test suite (named-test 'test-broken-method (get-suite was-run)))
+    (run-on-test-results suite result)
     (assert-equal "2 run, 0 erred, 1 failed" (summary result))))
 
-(defmethod test-dynamic-suite ((self test-case-test))
+(def-test-method (test-dynamic-suite self test-case-test :run nil)
   (assert-equal "3 run, 1 erred, 1 failed" 
-               (summary (run-test (make-test-suite 'was-run)))))
+               (summary (run (get-suite was-run)))))
+
 
-(textui-test-run (make-test-suite 'test-case-test) :handle-errors nil)
+(textui-test-run (get-suite test-case-test))
 
 
 (defun do-tests ()
-  (or (was-successful 
-       (run-test (make-test-suite 'test-case-test)))
+  (or (was-successful (run (get-suite test-case-test)))
       (error "Failed tests")))

diff --git a/xlunit.asd b/xlunit.asd
index 67c0fdd5647aca725bcb070a1f7c034c3be91f96..c7f293af20e0faba8ba17b02fe01833ffb6388be 100644 (file)
--- a/xlunit.asd
+++ b/xlunit.asd
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Aug 2003
 ;;;;
-;;;; $Id: xlunit.asd,v 1.4 2003/08/04 17:04:50 kevin Exp $
+;;;; $Id: xlunit.asd,v 1.5 2003/08/04 19:31:34 kevin Exp $
 ;;;; *************************************************************************
 
 (defpackage #:xlunit-system (:use #:asdf #:cl))
@@ -26,9 +26,9 @@
   ((:file "package")
    (:file "assert")
    (:file "tcase")
-   (:file "suite")
    (:file "listener")
    (:file "result")
+   (:file "suite")
    (:file "textui")
    (:file "printer")
    ))