X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcheck.lisp;h=5244704f9d3643c8107c218b728db8ec31e62dcf;hb=916f77e439bc09067ef611ab11c9f3630b80b4f5;hp=c5f3cab3bbe0b3c014298b366a0215e009de1add;hpb=5d375b445b191c9e1089eeddbef1e541db7e65f9;p=fiveam.git diff --git a/src/check.lisp b/src/check.lisp index c5f3cab..5244704 100644 --- a/src/check.lisp +++ b/src/check.lisp @@ -46,6 +46,22 @@ (:method ((o t)) nil) (:method ((o test-passed)) t)) +(define-condition check-failure (error) + ((reason :accessor reason :initarg :reason :initform "no reason given") + (test-case :accessor test-case :initarg :test-case) + (test-expr :accessor test-expr :initarg :test-expr)) + (:documentation "Signaled when a check fails.") + (:report (lambda (c stream) + (format stream "The following check failed: ~S~%~A." + (test-expr c) + (reason c))))) + +(defmacro process-failure (&rest args) + `(progn + (with-simple-restart (ignore-failure "Continue the test run.") + (error 'check-failure ,@args)) + (add-result 'test-failure ,@args))) + (defclass test-failure (test-result) () (:documentation "Class for unsuccessful checks.")) @@ -73,17 +89,6 @@ when appropiate.")) (:method ((o t)) nil) (:method ((o test-skipped)) t)) -(defparameter *debug-on-failure* nil - "If non-NIL then we drop into a debugger at each test failure.") - -(define-condition debug-test-failure (error) - ((failed-result :initarg :failed-result :accessor failed-result) - (failed-test :initarg :failed-test :accessor failed-test)) - (:report (lambda (condition stream) - (format stream "Test ~S failed with ~S." - (failed-test condition) - (failed-result condition))))) - (defun add-result (result-type &rest make-instance-args) "Create a TEST-RESULT object of type RESULT-TYPE passing it the initialize args MAKE-INSTANCE-ARGS and adds the resulting @@ -94,15 +99,7 @@ when appropiate.")) (etypecase result (test-passed (format *test-dribble* ".")) (unexpected-test-failure (format *test-dribble* "X")) - (test-failure - (when *debug-on-failure* - (restart-case - (invoke-debugger (make-instance 'debug-test-failure - :failed-test current-test - :failed-result result)) - (fail () - :report "Report a test failure and continue."))) - (format *test-dribble* "f")) + (test-failure (format *test-dribble* "f")) (test-skipped (format *test-dribble* "s"))) (push result result-list)))) @@ -150,18 +147,15 @@ Wrapping the TEST form in a NOT simply preducse a negated reason string." (setf bindings (list (list v ?value)) effective-test `(,?satisfies ,v) default-reason-args (list "~S did not satisfy ~S" v `',?satisfies))) - (t + (?_ (setf bindings '() effective-test test - default-reason-args "No reason supplied."))) + default-reason-args (list "No reason supplied")))) `(let ,bindings (if ,effective-test (add-result 'test-passed :test-expr ',test) - (add-result 'test-failure - :reason ,(if (null reason-args) - `(format nil ,@default-reason-args) - `(format nil ,@reason-args)) - :test-expr ',test)))))) + (process-failure :reason (format nil ,@(or reason-args default-reason-args)) + :test-expr ',test)))))) ;;;; *** Other checks @@ -171,17 +165,30 @@ Wrapping the TEST form in a NOT simply preducse a negated reason string." (format *test-dribble* "s") (add-result 'test-skipped :reason (format nil ,@reason)))) +(defmacro is-every (predicate &body clauses) + "The input is either a list of lists, or a list of pairs. Generates (is (,predicate ,expr ,value)) + for each pair of elements or (is (,predicate ,expr ,value) ,@reason) for each list." + `(progn + ,@(if (every #'consp clauses) + (loop for (expected actual &rest reason) in clauses + collect `(is (,predicate ,expected ,actual) ,@reason)) + (progn + (assert (evenp (list-length clauses))) + (loop for (expr value) on clauses by #'cddr + collect `(is (,predicate ,expr ,value))))))) + (defmacro is-true (condition &rest reason-args) "Like IS this check generates a pass if CONDITION returns true and a failure if CONDITION returns false. Unlike IS this check does not inspect CONDITION to determine how to report the failure." `(if ,condition - (add-result 'test-passed :test-expr ',condition) - (add-result 'test-failure :reason ,(if reason-args - `(format nil ,@reason-args) - `(format nil "~S did not return a true value" ',condition)) - :test-expr ',condition))) + (add-result 'test-passed :test-expr ',condition) + (process-failure + :reason ,(if reason-args + `(format nil ,@reason-args) + `(format nil "~S did not return a true value" ',condition)) + :test-expr ',condition))) (defmacro is-false (condition &rest reason-args) "Generates a pass if CONDITION returns false, generates a @@ -189,30 +196,36 @@ Wrapping the TEST form in a NOT simply preducse a negated reason string." not inspect CONDITION to determine what reason to give it case of test failure" `(if ,condition - (add-result 'test-failure :reason ,(if reason-args - `(format nil ,@reason-args) - `(format nil "~S returned a true value" ',condition)) - :test-expr ',condition) - (add-result 'test-passed :test-expr ',condition))) - -(defmacro signals (condition &body body) + (process-failure + :reason ,(if reason-args + `(format nil ,@reason-args) + `(format nil "~S returned a true value" ',condition)) + :test-expr ',condition) + (add-result 'test-passed :test-expr ',condition))) + +(defmacro signals (condition-spec + &body body) "Generates a pass if BODY signals a condition of type CONDITION. BODY is evaluated in a block named NIL, CONDITION is not evaluated." (let ((block-name (gensym))) - `(block ,block-name - (handler-bind ((,condition (lambda (c) - (declare (ignore c)) - ;; ok, body threw condition - (add-result 'test-passed - :test-expr ',condition) - (return-from ,block-name t)))) - (block nil - ,@body - (add-result 'test-failure - :reason (format nil "Failed to signal a ~S" ',condition) - :test-expr ',condition) - (return-from ,block-name nil)))))) + (destructuring-bind (condition &optional reason-control reason-args) + (ensure-list condition-spec) + `(block ,block-name + (handler-bind ((,condition (lambda (c) + (declare (ignore c)) + ;; ok, body threw condition + (add-result 'test-passed + :test-expr ',condition) + (return-from ,block-name t)))) + (block nil + ,@body)) + (process-failure + :reason ,(if reason-control + `(format nil ,reason-control ,@reason-args) + `(format nil "Failed to signal a ~S" ',condition)) + :test-expr ',condition) + (return-from ,block-name nil))))) (defmacro finishes (&body body) "Generates a pass if BODY executes to normal completion. In @@ -225,9 +238,9 @@ fails." (setf ok t)) (if ok (add-result 'test-passed :test-expr ',body) - (add-result 'test-failure - :reason (format nil "Test didn't finish") - :test-expr ',body))))) + (process-failure + :reason (format nil "Test didn't finish") + :test-expr ',body))))) (defmacro pass (&rest message-args) "Simply generate a PASS." @@ -238,10 +251,10 @@ fails." (defmacro fail (&rest message-args) "Simply generate a FAIL." - `(add-result 'test-failure - :test-expr ',message-args - ,@(when message-args - `(:reason (format nil ,@message-args))))) + `(process-failure + :test-expr ',message-args + ,@(when message-args + `(:reason (format nil ,@message-args))))) ;; Copyright (c) 2002-2003, Edward Marco Baringer ;; All rights reserved.