(: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."))
(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
(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
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
(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."
(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.
projects / fiveam.git / blobdiff