From 3d99efdf0959b199cc4b2e020c7692f650094f73 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Tue, 5 Aug 2003 23:00:28 +0000 Subject: [PATCH] r5459: *** empty log message *** --- assert.lisp | 22 +++++++++------ example.lisp | 4 +-- package.lisp | 5 ++-- printer.lisp | 77 ++++++++++++++++++++++++++-------------------------- result.lisp | 4 +-- suite.lisp | 4 +-- tcase.lisp | 8 ++---- tests.lisp | 38 ++++++++++++++++++++++---- xlunit.asd | 8 ++++-- 9 files changed, 101 insertions(+), 69 deletions(-) diff --git a/assert.lisp b/assert.lisp index d46eaeb..25db1e5 100644 --- a/assert.lisp +++ b/assert.lisp @@ -2,7 +2,7 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; ID: $Id: assert.lisp,v 1.5 2003/08/04 16:42:27 kevin Exp $ +;;;; ID: $Id: assert.lisp,v 1.6 2003/08/05 22:56:25 kevin Exp $ ;;;; Purpose: Assert functions for XLUnit ;;;; ;;;; ************************************************************************* @@ -14,12 +14,14 @@ ((message :initform nil :initarg :message :accessor message)) (:documentation "Base class for all test failures.")) +(defmethod print-object ((obj assertion-failed) stream) + (print-unreadable-object (obj stream :type t :identity nil) + (apply #'format stream (simple-condition-format-control obj) + (simple-condition-format-arguments obj)))) (defun failure-message (message &optional format-str &rest args) "Signal a test failure and exit the test." - (signal 'assertion-failed - :message message - :format-control format-str + (signal 'assertion-failed :message message :format-control format-str :format-arguments args)) (defun failure (format-str &rest args) @@ -28,16 +30,20 @@ (defun assert-equal (v1 v2 &optional message) (unless (equal v1 v2) - (failure-message message "Test equal: ~S ~S" v1 v2))) + (failure-message message "Assert equal: ~S ~S" v1 v2))) (defun assert-eql (v1 v2 &optional message) (unless (eql v1 v2) - (failure-message message "Test eql: ~S ~S" v1 v2))) + (failure-message message "Assert eql: ~S ~S" v1 v2))) + +(defun assert-not-eql (v1 v2 &optional message) + (when (eql v1 v2) + (failure-message message "Assert not eql: ~S ~S" v1 v2))) (defmacro assert-true (v &optional message) `(unless ,v - (failure-message message "Not true: ~S" ',v))) + (failure-message ,message "Assert true: ~S" ',v))) (defmacro assert-false (v &optional message) `(when ,v - (failure-message message "Not false: ~S" ',v))) + (failure-message ,message "Assert false: ~S" ',v))) diff --git a/example.lisp b/example.lisp index 4a89aec..5ddd148 100644 --- a/example.lisp +++ b/example.lisp @@ -2,7 +2,7 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; ID: $Id: example.lisp,v 1.7 2003/08/04 19:31:34 kevin Exp $ +;;;; ID: $Id: example.lisp,v 1.8 2003/08/05 22:56:25 kevin Exp $ ;;;; Purpose: Example file for XLUnit ;;;; ;;;; ************************************************************************* @@ -44,7 +44,7 @@ ;;; This method is meant to signal a failure (def-test-method (test-subtraction-2 test math-test-case :run nil) (let ((result (- (numbera test) (numberb test)))) - (assert-equal result 1))) + (assert-equal result 1 "This is meant to failure"))) ;;;; Finally we can run our test suite and see how it performs. (textui-test-run (get-suite math-test-case)) diff --git a/package.lisp b/package.lisp index 68562f2..24acae2 100644 --- a/package.lisp +++ b/package.lisp @@ -2,10 +2,10 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; ID: $Id: package.lisp,v 1.8 2003/08/04 19:31:34 kevin Exp $ +;;;; ID: $Id: package.lisp,v 1.9 2003/08/05 22:56:25 kevin Exp $ ;;;; Purpose: Package definition for XLUnit ;;;; -;;;; $Id: package.lisp,v 1.8 2003/08/04 19:31:34 kevin Exp $ +;;;; $Id: package.lisp,v 1.9 2003/08/05 22:56:25 kevin Exp $ ;;;; ************************************************************************* (in-package #:cl-user) @@ -28,6 +28,7 @@ #:assert-false #:assert-equal #:assert-eql + #:assert-not-eql #:test-failure #:failure diff --git a/printer.lisp b/printer.lisp index 3637ff4..ad351c8 100644 --- a/printer.lisp +++ b/printer.lisp @@ -2,7 +2,7 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; ID: $Id: printer.lisp,v 1.5 2003/08/04 19:31:34 kevin Exp $ +;;;; ID: $Id: printer.lisp,v 1.6 2003/08/05 22:56:25 kevin Exp $ ;;;; Purpose: Printer functions for XLUnit ;;;; ;;;; ************************************************************************* @@ -14,51 +14,50 @@ ; method print-results ;---------------------------------------------------------------------- -(defmethod print-results ((ob textui-test-runner) result seconds) - (format (ostream ob) "~&Time: ~D~%~%" (coerce seconds 'float)) - (print-header ob result) - (print-errors ob result) - (print-failures ob result) - t) +(defmethod print-results ((obj textui-test-runner) result seconds) + (print-header obj result seconds) + (print-defects obj (errors result) "error") + (print-defects obj (failures result) "failure") + (print-footer obj result) + (values)) -(defmethod print-header ((ob textui-test-runner) result) +(defmethod print-header ((obj textui-test-runner) result seconds) + (declare (ignore result)) + (format (ostream obj) "~&Time: ~D~%~%" (coerce seconds 'float))) + +(defmethod print-defects ((obj textui-test-runner) defects title) + (when defects + (let ((count (length defects))) + (if (= 1 count) + (format (ostream obj) "~%There was 1 ~A:~%" title) + (format (ostream obj) "~%There were ~D A:~%" + count title)) + (dotimes (i count) + (let* ((defect (nth i defects)) + (condition (thrown-condition defect))) + (format (ostream obj) "~A) ~A: " + (1+ i) (name (failed-test defect))) + (apply #'format (ostream obj) + (simple-condition-format-control condition) + (simple-condition-format-arguments condition)) + (format (ostream obj) "~%") + (when (message condition) + (let ((spaces (+ 2 (length (format nil "~D" count))))) + (dotimes (i spaces) + (write-char #\space (ostream obj)))) + (format (ostream obj) "~A~%" (message condition)))))))) + + +(defmethod print-footer ((obj textui-test-runner) result) (let ((failures (failures result)) (errors (errors result)) (run-tests (run-tests result))) (cond ((and (null failures) (null errors)) - (format (ostream ob) "~%OK (~a tests)~%" run-tests)) + (format (ostream obj) "~%OK (~a tests)~%" run-tests)) (t - (format (ostream ob) "~%~%FAILURES!!!~%") - (format (ostream ob) "Run: ~a Failures: ~a Errors: ~a~%" + (format (ostream obj) "~%~%FAILURES!!!~%") + (format (ostream obj) "Run: ~a Failures: ~a Errors: ~a~%" run-tests (length failures) (length errors)))))) - -(defmethod print-errors ((ob textui-test-runner) result) - (let ((errors (errors result))) - (when errors - (if (eql (length errors) 1) - (format (ostream ob) "~%There was 1 error:~%") - (format (ostream ob) "~%There were ~a errors:~%" (length errors))) - (let ((i 1)) - (mapc #'(lambda (single-error) - (format (ostream ob) "~a) ~a: ~a~%" i - (name (failed-test single-error)) - (thrown-condition single-error)) - (incf i)) - errors))))) - -(defmethod print-failures ((ob textui-test-runner) result) - (let ((failures (failures result))) - (when failures - (if (eql (length failures) 1) - (format (ostream ob) "~%There was 1 failure:~%") - (format (ostream ob) "~%There were ~a failures:~%" (length failures))) - (let ((i 1)) - (mapc #'(lambda (single-failure) - (format (ostream ob) "~a) ~a: ~a~%" i - (name (failed-test single-failure)) - (or (message (thrown-condition single-failure)) "")) - (incf i)) - failures))))) (defgeneric summary (result)) (defmethod summary ((result test-results)) diff --git a/result.lisp b/result.lisp index eb49d0f..28baaa5 100644 --- a/result.lisp +++ b/result.lisp @@ -2,7 +2,7 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; ID: $Id: result.lisp,v 1.6 2003/08/04 19:31:34 kevin Exp $ +;;;; ID: $Id: result.lisp,v 1.7 2003/08/05 22:56:25 kevin Exp $ ;;;; Purpose: Result functions for XLUnit ;;;; ;;;; ************************************************************************* @@ -56,7 +56,7 @@ (defmethod is-failure ((failure test-failure)) "Returns T if a failure was a test-failure condition" - (typep (thrown-condition failure) 'test-failure-condition)) + (typep (thrown-condition failure) 'assertion-failed)) (defmethod print-object ((obj test-failure) stream) (print-unreadable-object (obj stream :type t :identity nil) diff --git a/suite.lisp b/suite.lisp index f2394ab..391258e 100644 --- a/suite.lisp +++ b/suite.lisp @@ -2,7 +2,7 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; ID: $Id: suite.lisp,v 1.6 2003/08/04 19:31:34 kevin Exp $ +;;;; ID: $Id: suite.lisp,v 1.7 2003/08/05 22:56:25 kevin Exp $ ;;;; Purpose: Suite functions for XLUnit ;;;; ;;;; ************************************************************************* @@ -42,7 +42,7 @@ (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)) + (eq existing-tests-or-suite test)) ((typep existing-tests-or-suite 'test-case) (eql (name existing-tests-or-suite) (name test))))) diff --git a/tcase.lisp b/tcase.lisp index 62cb8bf..414eee8 100644 --- a/tcase.lisp +++ b/tcase.lisp @@ -2,7 +2,7 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; ID: $Id: tcase.lisp,v 1.3 2003/08/04 19:58:24 kevin Exp $ +;;;; ID: $Id: tcase.lisp,v 1.4 2003/08/05 22:56:25 kevin Exp $ ;;;; Purpose: Test fixtures for XLUnit ;;;; ;;;; ************************************************************************* @@ -59,7 +59,7 @@ that the setup method did for this instance.")) (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) + (run-on-test-results ob res :handle-errors handle-errors) res)) (defmethod run-on-test-results ((test test-case) result @@ -87,7 +87,3 @@ that the setup method did for this instance.")) (add-error res test condition))) (run-base test)) res) - - - - diff --git a/tests.lisp b/tests.lisp index 0cba6c3..2659b84 100644 --- a/tests.lisp +++ b/tests.lisp @@ -2,8 +2,8 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Id: $Id: tests.lisp,v 1.10 2003/08/04 19:42:18 kevin Exp $ -;;;; Purpose: Test suite for XLUnit +;;;; Id: $Id: tests.lisp,v 1.11 2003/08/05 22:56:25 kevin Exp $ +;;;; Purpose: Self Test suite for XLUnit ;;;; ;;;; ************************************************************************* @@ -33,10 +33,28 @@ (def-test-method (test-broken-method self was-run :run nil) (assert-equal pi (/ 22 7))) +(def-test-method (test-not-eql self was-run :run nil) + (assert-not-eql (cons t t) (cons t t))) + +(def-test-method (test-eql self was-run :run nil) + (let ((obj (cons t t))) + (assert-eql obj obj))) + (def-test-method (test-error-method self was-run :run nil) (error "Err")) +;;; Second helper test case + +(defclass test-two-cases (test-case) + ()) + +(def-test-method (test-1 self test-two-cases :run nil) + (assert-true t)) + +(def-test-method (test-2 self test-two-cases :run nil) + (assert-false nil)) + ;;; Main test fixture (defclass test-case-test (test-case) @@ -50,7 +68,17 @@ (def-test-method (test-results self test-case-test :run nil) (assert-equal "1 run, 0 erred, 0 failed" - (summary (run (named-test 'test-method (get-suite was-run)))))) + (summary (run (named-test 'test-method + (get-suite was-run)))))) + +(def-test-method (test-eql self test-case-test :run nil) + (assert-equal "1 run, 0 erred, 0 failed" + (summary (run (named-test 'test-eql (get-suite was-run)))))) + +(def-test-method (test-not-eql self test-case-test :run nil) + (assert-equal "1 run, 0 erred, 0 failed" + (summary (run (named-test 'test-not-eql + (get-suite was-run)))))) (def-test-method (test-fn self test-case-test :run nil) (let ((test (make-instance 'test-case :name 'test-fn @@ -82,8 +110,8 @@ (assert-equal "2 run, 0 erred, 1 failed" (summary result)))) (def-test-method (test-dynamic-suite self test-case-test :run nil) - (assert-equal "3 run, 1 erred, 1 failed" - (summary (run (get-suite was-run))))) + (assert-equal "2 run, 0 erred, 0 failed" + (summary (run (get-suite test-two-cases))))) (textui-test-run (get-suite test-case-test)) diff --git a/xlunit.asd b/xlunit.asd index c7f293a..a3f5e27 100644 --- a/xlunit.asd +++ b/xlunit.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Aug 2003 ;;;; -;;;; $Id: xlunit.asd,v 1.5 2003/08/04 19:31:34 kevin Exp $ +;;;; $Id: xlunit.asd,v 1.6 2003/08/05 22:56:25 kevin Exp $ ;;;; ************************************************************************* (defpackage #:xlunit-system (:use #:asdf #:cl)) @@ -34,14 +34,16 @@ )) (defmethod perform ((o test-op) (c (eql (find-system 'xlunit)))) - (oos 'load-op 'xlunit-tests :force t) - (oos 'test-op 'xlunit-tests :force t)) + (operate 'load-op 'xlunit-tests :force t) + (operate 'test-op 'xlunit-tests :force t)) (defsystem xlunit-tests :depends-on (xlunit) :components ((:file "tests"))) (defmethod perform ((o test-op) (c (eql (find-system 'xlunit-tests)))) + (operate 'load-op 'xlunit-tests) (or (funcall (intern (symbol-name '#:do-tests) (find-package '#:xlunit-tests))) (error "test-op failed"))) + -- 2.34.1