;;;; *************************************************************************
;;;; 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
;;;;
;;;; *************************************************************************
((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)
(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)))
;;;; *************************************************************************
;;;; 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
;;;;
;;;; *************************************************************************
;;; 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))
;;;; *************************************************************************
;;;; 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)
#:assert-false
#:assert-equal
#:assert-eql
+ #:assert-not-eql
#:test-failure
#:failure
;;;; *************************************************************************
;;;; 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
;;;;
;;;; *************************************************************************
; 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))
;;;; *************************************************************************
;;;; 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
;;;;
;;;; *************************************************************************
(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)
;;;; *************************************************************************
;;;; 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
;;;;
;;;; *************************************************************************
(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)))))
;;;; *************************************************************************
;;;; 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
;;;;
;;;; *************************************************************************
(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
(add-error res test condition)))
(run-base test))
res)
-
-
-
-
;;;; *************************************************************************
;;;; 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
;;;;
;;;; *************************************************************************
(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)
(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
(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))
;;;; 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))
))
(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")))
+